usrtpl.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL
C>   SUBSET ARRAYS IN MODULE USRINT FOR CASES OF NODE EXPANSION
C>   (I.E. WHEN THE NODE IS EITHER A TABLE A MNEMONIC OR A DELAYED
C>   REPLICATION FACTOR).
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C>                           INCREASED FROM 15000 TO 16000 (WAS IN
C>                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C>                           WRF; ADDED DOCUMENTATION (INCLUDING
C>                           HISTORY) (INCOMPLETE); OUTPUTS MORE
C>                           COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C>                           TERMINATES ABNORMALLY OR UNUSUAL THINGS
C>                           HAPPEN; COMMENTED OUT HARDWIRE OF VTMP TO
C>                           "BMISS" (10E10) WHEN IT IS > 10E9 (CAUSED
C>                           PROBLEMS ON SOME FOREIGN MACHINES)
C> 2009-03-31  J. WOOLLEN -- ADD DOCUMENTATION
C> 2009-04-21  J. ATOR    -- USE ERRWRT
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL USRTPL (LUN, INVN, NBMP)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>     INVN     - INTEGER: STARTING JUMP/LINK TABLE INDEX OF THE NODE
C>                TO BE EXPANDED WITHIN THE SUBSET TEMPLATE
C>     NBMP     - INTEGER: NUMBER OF TIMES BY WHICH INVN IS TO BE
C>                EXPANDED (I.E. NUMBER OF REPLICATIONS OF NODE)
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     ERRWRT
C>    THIS ROUTINE IS CALLED BY: DRFINI   DRSTPL   MSGUPD   OPENMB
C>                               OPENMG   RDCMPS   TRYBUMP  UFBGET
C>                               UFBTAB   UFBTAM   WRCMPS   WRITLC
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE usrtpl(LUN,INVN,NBMP)

      USE moda_usrint
      USE moda_msgcwd
      USE moda_tables
      USE moda_ivttmp

      COMMON /quiet / iprt

      CHARACTER*128 bort_str,errstr
      LOGICAL       drp,drs,drb,drx

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

      IF(iprt.GE.2)  THEN
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
         WRITE ( unit=errstr, fmt='(A,I3,A,I7,A,I5,A,A10)' )
     .      'BUFRLIB: USRTPL - LUN:INVN:NBMP:TAG(INODE(LUN)) = ',
     .      lun, ':', invn, ':', nbmp, ':', tag(inode(lun))
         CALL errwrt(errstr)
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL errwrt(' ')
      ENDIF

      IF(nbmp.LE.0) THEN
         IF(iprt.GE.1)  THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(.LE.'BUFRLIB: USRTPL - NBMP  0 - IMMEDIATE RETURN')
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         goto 100
      ENDIF

      drp = .false.
      drs = .false.
      drx = .false.

C  SET UP A NODE EXPANSION
C  -----------------------

      IF(invn.EQ.1) THEN
c  .... case where node is a Table A mnemonic (nodi is positional index)
         nodi = inode(lun)
         inv(1,lun) = nodi
         nval(lun)  = 1
         IF(nbmp.NE.1) goto 900
      ELSEIF(invn.GT.0 .AND. invn.LE.nval(lun)) THEN
c  .... case where node is (hopefully) a delayed replication factor
         nodi = inv(invn,lun)
         drp  = typ(nodi) .EQ. 'DRP'
         drs  = typ(nodi) .EQ. 'DRS'
         drb  = typ(nodi) .EQ. 'DRB'
         drx  = drp .OR. drs .OR. drb
         ival = val(invn,lun)
         jval = 2**ibt(nodi)-1
         val(invn,lun) = ival+nbmp
         IF(drb.AND.nbmp.NE.1) goto 901
         IF(.NOT.drx         ) goto 902
         IF(ival.LT.0.       ) goto 903
         IF(ival+nbmp.GT.jval) goto 904
      ELSE
         goto 905
      ENDIF

C  RECALL A PRE-FAB NODE EXPANSION SEGMENT
C  ---------------------------------------

      newn = 0
      n1 = iseq(nodi,1)
      n2 = iseq(nodi,2)

      IF(n1.EQ.0          ) goto 906
      IF(n2-n1+1.GT.maxjl)  goto 907

      DO n=n1,n2
      newn = newn+1
      itmp(newn) = jseq(n)
      vtmp(newn) = vali(jseq(n))
      ENDDO

C  MOVE OLD NODES - STORE NEW ONES
C  -------------------------------

      IF(nval(lun)+newn*nbmp.GT.maxss) goto 908

      DO j=nval(lun),invn+1,-1
      inv(j+newn*nbmp,lun) = inv(j,lun)
      val(j+newn*nbmp,lun) = val(j,lun)
      ENDDO

      IF(drp.OR.drs) vtmp(1) = newn
      knvn = invn

      DO i=1,nbmp
      DO j=1,newn
      knvn = knvn+1
      inv(knvn,lun) = itmp(j)
      val(knvn,lun) = vtmp(j)
      ENDDO
      ENDDO

C  RESET POINTERS AND COUNTERS
C  ---------------------------

      nval(lun) = nval(lun) + newn*nbmp

      IF(iprt.GE.2)  THEN
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
         WRITE ( unit=errstr, fmt='(A,A,A10,2(A,I5),A,I7)' )
     .      'BUFRLIB: USRTPL - TAG(INV(INVN,LUN)):NEWN:NBMP:',
     .      'NVAL(LUN) = ', tag(inv(invn,lun)), ':', newn, ':',
     .      nbmp, ':', nval(lun)
         CALL errwrt(errstr)
         DO i=1,newn
           WRITE ( unit=errstr, fmt='(2(A,I5),A,A10)' )
     .      'For I = ', i, ', ITMP(I) = ', itmp(i),
     .      ', TAG(ITMP(I)) = ', tag(itmp(i))
           CALL errwrt(errstr)
         ENDDO
      CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      CALL errwrt(' ')
      ENDIF

      IF(drx) THEN
         node = nodi
         invr = invn
4        node = jmpb(node)
         IF(node.GT.0) THEN
            IF(itp(node).EQ.0) THEN
               DO invr=invr-1,1,-1
               IF(inv(invr,lun).EQ.node) THEN
                  val(invr,lun) = val(invr,lun)+newn*nbmp
                  goto 4
               ENDIF
               ENDDO
               goto 909
            ELSE
               goto 4
            ENDIF
         ENDIF
      ENDIF

C  EXITS
C  -----

100   RETURN
900   WRITE(bort_str,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'//
     . 'I4,", MUST BE 1 WHEN SECOND ARGUMENT (INPUT) IS 1 (SUBSET '//
     . 'NODE) (",A,")")') nbmp,tag(nodi)
      CALL bort(bort_str)
901   WRITE(bort_str,'("BUFRLIB: USRTPL - THIRD ARGUMENT (INPUT) = ",'//
     . 'I4,", MUST BE 1 WHEN NODE IS DRB (1-BIT DELAYED REPL. FACTOR)'//
     . ' (",A,")")') nbmp,tag(nodi)
      CALL bort(bort_str)
902   WRITE(bort_str,'("BUFRLIB: USRTPL - NODE IS OF TYPE ",A," - IT '//
     . 'MUST BE EITHER A SUBSET OR DELAYED REPL. FACTOR (",A,")")')
     .  typ(nodi),tag(nodi)
      CALL bort(bort_str)
903   WRITE(bort_str,'("BUFRLIB: USRTPL - REPLICATION FACTOR IS '//
     . 'NEGATIVE (=",I5,") (",A,")")') ival,tag(nodi)
      CALL bort(bort_str)
904   WRITE(bort_str,'("BUFRLIB: USRTPL - REPLICATION FACTOR OVERFLOW'//
     . ' (EXCEEDS MAXIMUM OF",I6," (",A,")")') jval,tag(nodi)
      CALL bort(bort_str)
905   WRITE(bort_str,'("BUFRLIB: USRTPL - INVENTORY INDEX {FIRST '//
     . 'ARGUMENT (INPUT)} OUT OF BOUNDS (=",I5,", RANGE IS 1 TO",I6,"'//
     . ') (",A,")")') invn,nval(lun),tag(nodi)
      CALL bort(bort_str)
906   WRITE(bort_str,'("BUFRLIB: USRTPL - UNSET EXPANSION SEGMENT (",'//
     . 'A,")")') tag(nodi)
      CALL bort(bort_str)
907   WRITE(bort_str,'("BUFRLIB: USRTPL - TEMPLATE ARRAY OVERFLOW, '//
     . 'EXCEEDS THE LIMIT (",I6,") (",A,")")') maxjl,tag(nodi)
      CALL bort(bort_str)
908   WRITE(bort_str,'("BUFRLIB: USRTPL - INVENTORY OVERFLOW (",I6,")'//
     . ', EXCEEDS THE LIMIT (",I6,") (",A,")")')
     . nval(lun)+newn*nbmp,maxss,tag(nodi)
      CALL bort(bort_str)
909   WRITE(bort_str,'("BUFRLIB: USRTPL - BAD BACKUP STRATEGY (",A,'//
     . '")")') tag(nodi)
      CALL bort(bort_str)
      END