tabsub.f

Go to the documentation of this file.

C> @file
C> @brief Store an entry for a Table A mnemonic within the internal jump/link table.
C>
C> @author Woollen @date 1994-01-06
 
C> This subroutine builds the entire jump/link tree
C> (including recursively resolving all "child" mnemonics) for a Table A
C> 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 A mnemonic.
C>
C> @author Woollen @date 1994-01-06
      SUBROUTINE tabsub(LUN,NEMO)
 
      USE modv_mxtamc
      USE modv_mxtco
 
      USE moda_tables
      USE moda_nmikrp
      USE moda_nrv203
      USE moda_bitmaps
 
      COMMON /tabccc/ icdw,icsc,icrv,incw
 
      CHARACTER*128 BORT_STR
      CHARACTER*8   NEMO,NEMS
      CHARACTER*1   TAB
      dimension     drop(10),jmp0(10),nodl(10),ntag(10,2)
      LOGICAL       DROP,LTAMC
 
      DATA maxlim /10/
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  CHECK THE MNEMONIC
C  ------------------
 
C     Note that Table A mnemonics, in addition to being stored within
C     internal BUFR Table A array TABA(*,LUN), are also stored as
C     Table D mnemonics within internal BUFR Table D array TABD(*,LUN).
C     Thus, the following test is valid.
 
      CALL nemtab(lun,nemo,idn,tab,itab)
      IF(tab.NE.'D') GOTO 900
 
C  STORE A SUBSET NODE AND JUMP/LINK THE TREE
C  ------------------------------------------
 
      CALL inctab(nemo,'SUB',node)
      jump(node) = node+1
      jmpb(node) = 0
      link(node) = 0
      ibt(node) = 0
      irf(node) = 0
      isc(node) = 0
 
      CALL nemtbd(lun,itab,nseq,nem(1,1),irp(1,1),krp(1,1))
      ntag(1,1) = 1
      ntag(1,2) = nseq
      jmp0(1)   = node
      nodl(1)   = node
      limb      = 1
 
      icdw = 0
      icsc = 0
      icrv = 1
      incw = 0
 
      ibtnrv = 0
      ipfnrv = 0
 
      IF(ntamc+1.GT.mxtamc) GOTO 913
      inodtamc(ntamc+1) = node
      ntco(ntamc+1) = 0
      ltamc = .false.
 
C  THIS LOOP RESOLVES ENTITIES IN A SUBSET BY EMULATING RECURSION
C  --------------------------------------------------------------
 
1     DO n=ntag(limb,1),ntag(limb,2)
 
      ntag(limb,1) = n+1
      drop(limb)   = n.EQ.ntag(limb,2)
 
      CALL nemtab(lun,nem(n,limb),idn,tab,itab)
      nems = nem(n,limb)
 
C  SPECIAL TREATMENT FOR CERTAIN OPERATOR DESCRIPTORS (TAB=C)
C  ----------------------------------------------------------
 
      IF(tab.EQ.'C') THEN
         READ(nems,'(3X,I3)') iyyy
         IF(itab.EQ.1) THEN
            IF(iyyy.NE.0) THEN
              IF(icdw.NE.0) GOTO 907
              icdw = iyyy-128
            ELSE
              icdw = 0
            ENDIF
         ELSEIF(itab.EQ.2) THEN
            IF(iyyy.NE.0) THEN
              IF(icsc.NE.0) GOTO 908
              icsc = iyyy-128
            ELSE
              icsc = 0
            ENDIF
         ELSEIF(itab.EQ.3) THEN
            IF(iyyy.EQ.0) THEN
 
C             Stop applying new reference values to subset nodes.
C             Instead, revert to the use of standard Table B values.
 
              IF(ipfnrv.EQ.0) GOTO 911
              DO jj=ipfnrv,nnrv
                ienrv(jj) = ntab
              ENDDO
              ipfnrv = 0
            ELSEIF(iyyy.EQ.255) THEN
 
C             End the definition of new reference values.
 
              ibtnrv = 0
            ELSE
 
C             Begin the definition of new reference values.
 
              IF(ibtnrv.NE.0) GOTO 909
              ibtnrv = iyyy
            ENDIF
         ELSEIF(itab.EQ.7) THEN
            IF(iyyy.GT.0) THEN
              IF(icdw.NE.0) GOTO 907
              IF(icsc.NE.0) GOTO 908
              icdw = ((10*iyyy)+2)/3
              icsc = iyyy
              icrv = 10**iyyy
            ELSE
              icsc = 0
              icdw = 0
              icrv = 1
            ENDIF
         ELSEIF(itab.EQ.8) THEN
            incw = iyyy
         ELSEIF((itab.GE.21).AND.(iokoper(nems).EQ.1)) THEN
 
C           Save the location of this operator within the
C           jump/link table, for possible later use.
 
            IF(.NOT.ltamc) THEN
              ltamc = .true.
              ntamc = ntamc+1
            END IF
            IF(ntco(ntamc)+1.GT.mxtco) GOTO 912
            ntco(ntamc) = ntco(ntamc)+1
            ctco(ntamc,ntco(ntamc)) = nems(1:6)
            inodtco(ntamc,ntco(ntamc)) = ntab
         ENDIF
      ELSE
         nodl(limb) = ntab+1
         irep = irp(n,limb)
         iknt = krp(n,limb)
         jum0 = jmp0(limb)
         CALL tabent(lun,nems,tab,itab,irep,iknt,jum0)
      ENDIF
 
      IF(tab.EQ.'D') THEN
 
C        Note here how a new tree "LIMB" is created (and is then
C        immediately recursively resolved) whenever a Table D mnemonic
C        contains another Table D mnemonic as one of its children.
 
         limb = limb+1
         IF(limb.GT.maxlim) GOTO 901
         CALL nemtbd(lun,itab,nseq,nem(1,limb),irp(1,limb),krp(1,limb))
         ntag(limb,1) = 1
         ntag(limb,2) = nseq
         jmp0(limb)   = ntab
         GOTO 1
      ELSEIF(drop(limb)) THEN
2        link(nodl(limb)) = 0
         limb = limb-1
         IF(limb.EQ.0 ) THEN
            IF(icrv.NE.1) GOTO 904
            IF(icdw.NE.0) GOTO 902
            IF(icsc.NE.0) GOTO 903
            IF(incw.NE.0) GOTO 905
            IF(ibtnrv.NE.0) GOTO 910
            IF(ipfnrv.NE.0) THEN
 
C             One or more new reference values were defined for this
C             subset, but there was no subsequent 2-03-000 operator,
C             so set all IENRV(*) values for this subset to point to
C             the last element of the subset within the jump/link table.
C             Note that, if there had been a subsequent 2-03-000
C             operator, then these IENRV(*) values would have already
C             been properly set above.
 
              DO jj=ipfnrv,nnrv
                ienrv(jj) = ntab
              ENDDO
            ENDIF
            GOTO 100
         ENDIF
         IF(drop(limb)) GOTO 2
         link(nodl(limb)) = ntab+1
         GOTO 1
      ELSEIF(tab.NE.'C') THEN
         link(nodl(limb)) = ntab+1
      ENDIF
 
      ENDDO
 
      GOTO 906
 
C  EXITS
C  -----
 
100   RETURN
900   WRITE(bort_str,'("BUFRLIB: TABSUB - SUBSET NODE NOT IN TABLE D '//
     . '(TAB=",A,") FOR INPUT MNEMONIC ",A)') tab,nemo
      CALL bort(bort_str)
901   WRITE(bort_str,'("BUFRLIB: TABSUB - THERE ARE TOO MANY NESTED '//
     . 'TABLE D SEQUENCES (TREES) WITHIN INPUT MNEMONIC ",A," - THE '//
     . 'LIMIT IS",I4)') nemo,maxlim
      CALL bort(bort_str)
902   WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-01-YYY OPERATOR WAS '//
     . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
      CALL bort(bort_str)
903   WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-02-YYY OPERATOR WAS '//
     . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
      CALL bort(bort_str)
904   WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-07-YYY OPERATOR WAS '//
     . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
      CALL bort(bort_str)
905   WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-08-YYY OPERATOR WAS '//
     . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
      CALL bort(bort_str)
906   WRITE(bort_str,'("BUFRLIB: TABSUB - ENTITIES WERE NOT '//
     . 'SUCCESSFULLY RESOLVED (BY EMULATING RESURSION) FOR SUBSET '//
     . 'DEFINED BY TBL A MNEM. ",A)') nemo
      CALL bort(bort_str)
907   WRITE(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '//
     . 'CHANGE DATA WIDTH OPERATIONS IN THE TREE BUILT FROM INPUT ' //
     . 'MNEMONIC ",A)') nemo
      CALL bort(bort_str)
908   WRITE(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '//
     . 'CHANGE DATA SCALE OPERATIONS IN THE TREE BUILT FROM INPUT ' //
     . 'MNEMONIC ",A)') nemo
      CALL bort(bort_str)
909   WRITE(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '//
     . 'CHANGE REF VALUE OPERATIONS IN THE TREE BUILT FROM INPUT ' //
     . 'MNEMONIC ",A)') nemo
      CALL bort(bort_str)
910   WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-03-YYY OPERATOR WAS '//
     . 'APPLIED WITHOUT ANY SUBSEQUENT 2-03-255 OPERATOR FOR '//
     . 'INPUT MNEMONIC ",A)') nemo
      CALL bort(bort_str)
911   WRITE(bort_str,'("BUFRLIB: TABSUB - A 2-03-000 OPERATOR WAS '//
     . 'ENCOUNTERED WITHOUT ANY PRIOR 2-03-YYY OPERATOR FOR '//
     . 'INPUT MNEMONIC ",A)') nemo
      CALL bort(bort_str)
912   CALL bort('BUFRLIB: TABSUB - MXTCO OVERFLOW')
913   CALL bort('BUFRLIB: TABSUB - MXTAMC OVERFLOW')
      END