usrtpl.f

Go to the documentation of this file.

C> @file
C> @brief Store the subset template into internal arrays.
C>
C> @author J. Woollen @date 1994-01-06
 
C> Store the subset template into internal arrays.
C>
C> This subroutine stores the subset template into internal
C> subset arrays in module @ref moda_usrint for cases of node expansion,
C> such as when the node is either a Table A mnemonic or a delayed
C> replication factor.
C>
C> @param[in] LUN - integer: File ID.
C> @param[in] INVN - integer: Starting jump/link table index of the node
C> to be expanded within the subset template.
C> @param[in] NBMP - integer: Number of times by which INVN is to be
C> expanded (i.e. number of replications of node).
C>
C> @author J. Woollen @date 1994-01-06
 
      SUBROUTINE usrtpl(LUN,INVN,NBMP)
 
      USE modv_maxjl
      USE modv_maxss
 
      USE moda_usrint
      USE moda_msgcwd
      USE moda_tables
      USE moda_ivttmp
      use moda_stcode
 
      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 = nint(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 errwrt(bort_str)
      iscodes(lun) = 1
      return
905   WRITE(bort_str,'("BUFRLIB: USRTPL - INVENTORY INDEX {FIRST '//
     . 'ARGUMENT (INPUT)} OUT OF BOUNDS (=",I5,", RANGE IS 1 TO",I6,"'//
     . ') ")') invn,nval(lun)
      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