tabent.f

Go to the documentation of this file.

C> @file
C> @brief Store an entry for a Table B or D mnemonic within the internal jump/link table.
C>
C> @author Woollen @date 1994-01-06
 
C> This subroutine builds and stores an entry for a Table B or
c> Table D mnemonic within the internal jump/link table.
C>
C> @param[in] LUN - integer: I/O stream index into internal memory arrays.
C> @param[in] NEMO - character*8: Table B or D mnemonic to store in jump/link table.
C> @param[in] TAB - character*1: internal BUFR table array ('B' or 'D') in which NEMO is defined.
C> @param[in] ITAB - integer: positional index of NEMO within TAB.
C> @param[in] IREP - integer: positional index within common /reptab/ arrays,
C> for use when NEMO is replicated:
C> - 0, if NEMO is not replicated.
C> @param[in] IKNT - integer: number of replications, for use when NEMO is
C> replicated using F=1 regular (i.e., non-delayed) replication:
C> - 0, if NEMO is not replicated using F=1 regular (i.e., non-delayed) replication
C> @param[in] JUM0 - integer: index value to be stored for NEMO within internal jump/link table array jmpb(*).
C>
C> @author Woollen @date 1994-01-06
      SUBROUTINE tabent(LUN,NEMO,TAB,ITAB,IREP,IKNT,JUM0)
 
      USE modv_mxnrv
 
      USE moda_tables
      USE moda_nrv203
 
C     Note that the values within the COMMON /REPTAB/ arrays were
C     initialized within subroutine BFRINI.
 
      COMMON /reptab/ idnr(5,2),typs(5,2),reps(5,2),lens(5)
 
      COMMON /tabccc/ icdw,icsc,icrv,incw
 
      CHARACTER*128 BORT_STR
      CHARACTER*24  UNIT
      CHARACTER*10  RTAG
      CHARACTER*8   NEMO
      CHARACTER*3   TYPS,TYPT
      CHARACTER*1   REPS,TAB
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  MAKE A JUMP/LINK TABLE ENTRY FOR A REPLICATOR
C  ---------------------------------------------
 
      IF(irep.NE.0) THEN
         rtag = reps(irep,1)//nemo
         DO i=1,10
         IF(rtag(i:i).EQ.' ') THEN
            rtag(i:i) = reps(irep,2)
            CALL inctab(rtag,typs(irep,1),node)
            jump(node) = node+1
            jmpb(node) = jum0
            link(node) = 0
            ibt(node) = lens(irep)
            irf(node) = 0
            isc(node) = 0
            IF(irep.EQ.1) irf(node) = iknt
            jum0 = node
            GOTO 1
         ENDIF
         ENDDO
         GOTO 900
      ENDIF
 
C  MAKE AN JUMP/LINK ENTRY FOR AN ELEMENT OR A SEQUENCE
C  ----------------------------------------------------
 
1     IF(tab.EQ.'B') THEN
 
         CALL nemtbb(lun,itab,unit,iscl,iref,ibit)
         IF(unit(1:5).EQ.'CCITT') THEN
            typt = 'CHR'
         ELSE
            typt = 'NUM'
         ENDIF
         CALL inctab(nemo,typt,node)
         jump(node) = 0
         jmpb(node) = jum0
         link(node) = 0
         ibt(node) = ibit
         irf(node) = iref
         isc(node) = iscl
         IF(unit(1:4).EQ.'CODE') THEN
            typt = 'COD'
         ELSEIF(unit(1:4).EQ.'FLAG') THEN
            typt = 'FLG'
         ENDIF
 
         IF( (typt.EQ.'NUM') .AND. (ibtnrv.NE.0) ) THEN
 
C           This node contains a new (redefined) reference value.
 
            IF(nnrv+1.GT.mxnrv) GOTO 902
            nnrv = nnrv+1
            tagnrv(nnrv) = nemo
            inodnrv(nnrv) = node
            isnrv(nnrv) = node+1
            ibt(node) = ibtnrv
            IF(ipfnrv.EQ.0) ipfnrv = nnrv
         ELSEIF( (typt.EQ.'NUM') .AND. (nemo(1:3).NE.'204') ) THEN
            ibt(node) = ibt(node) + icdw
            isc(node) = isc(node) + icsc
            irf(node) = irf(node) * icrv
         ELSEIF( (typt.EQ.'CHR') .AND. (incw.GT.0) ) THEN
            ibt(node) = incw * 8
         ENDIF
 
      ELSEIF(tab.EQ.'D') THEN
 
         IF(irep.EQ.0) THEN
            typt = 'SEQ'
         ELSE
            typt = typs(irep,2)
         ENDIF
         CALL inctab(nemo,typt,node)
         jump(node) = node+1
         jmpb(node) = jum0
         link(node) = 0
         ibt(node) = 0
         irf(node) = 0
         isc(node) = 0
 
      ELSE
 
         GOTO 901
 
      ENDIF
 
C  EXITS
C  -----
 
      RETURN
900   WRITE(bort_str,'("BUFRLIB: TABENT - REPLICATOR ERROR FOR INPUT '//
     . 'MNEMONIC ",A,", RTAG IS ",A)') nemo,rtag
      CALL bort(bort_str)
901   WRITE(bort_str,'("BUFRLIB: TABENT - UNDEFINED TAG (",A,") FOR '//
     . 'INPUT MNEMONIC ",A)') tab,nemo
      CALL bort(bort_str)
902   CALL bort('BUFRLIB: TABENT - MXNRV OVERFLOW')
      END