tabent.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE BUILDS AND STORES AN ENTRY FOR A TABLE B OR
C>   TABLE D MNEMONIC (NEMO) WITHIN THE INTERNAL JUMP/LINK TABLE.
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"; CORRECTED SOME MINOR ERRORS
C> 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
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 HISTORY DOCUMENTATION; OUTPUTS
C>                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C>                           TERMINATES ABNORMALLY
C> 2005-11-29  J. ATOR    -- ADDED SUPPORT FOR 207 AND 208 OPERATORS
C> 2010-03-19  J. ATOR    -- ADDED SUPPORT FOR 204 OPERATOR
C> 2012-03-02  J. ATOR    -- ADDED SUPPORT FOR 203 OPERATOR
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL TABENT (LUN, NEMO, TAB, ITAB, IREP, IKNT, JUM0)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>     NEMO     - CHARACTER*8: TABLE B OR D MNEMONIC TO STORE IN JUMP/
C>                LINK TABLE
C>     TAB      - CHARACTER*1: INTERNAL BUFR TABLE ARRAY ('B' OR 'D') IN
C>                WHICH NEMO IS DEFINED
C>     ITAB     - INTEGER: POSITIONAL INDEX OF NEMO WITHIN TAB
C>     IREP     - INTEGER: POSITIONAL INDEX WITHIN COMMON /REPTAB/
C>                ARRAYS, FOR USE WHEN NEMO IS REPLICATED:
C>                       0 = NEMO is not replicated
C>     IKNT     - INTEGER: NUMBER OF REPLICATIONS, FOR USE WHEN NEMO IS
C>                REPLICATED USING F=1 REGULAR (I.E., NON-DELAYED)
C>                REPLICATION:
C>                       0 = NEMO is not replicated using F=1 regular
C>                           (i.e., non-delayed) replication
C>     JUM0     - INTEGER: INDEX VALUE TO BE STORED FOR NEMO WITHIN
C>                INTERNAL JUMP/LINK TABLE ARRAY JMPB(*)
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     INCTAB   NEMTBB
C>    THIS ROUTINE IS CALLED BY: TABSUB
C>                               Normally not called by any application
C>                               programs.
C>
      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