tabsub.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE BUILDS THE ENTIRE JUMP/LINK TREE (I.E.,
C>   INCLUDING RECURSIVELY RESOLVING ALL "CHILD" MNEMONICS) FOR A TABLE
C>   A 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"
C> 2000-09-19  J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA
C>                           USING THE OPERATOR DESCRIPTORS (BUFR TABLE
C>                           C) FOR CHANGING WIDTH AND CHANGING SCALE
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> 2012-03-02  J. ATOR    -- ADDED SUPPORT FOR 203 OPERATOR
C> 2012-04-19  J. ATOR    -- FIXED BUG FOR CASES WHERE A TABLE C OPERATOR
C>                           IMMEDIATELY FOLLOWS A TABLE D SEQUENCE
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> 2016-05-24  J. ATOR    -- STORE TABLE C OPERATORS IN MODULE BITMAPS
C> 2017-04-03  J. ATOR    -- ADD A DIMENSION TO ALL TCO ARRAYS SO THAT
C>                           EACH SUBSET DEFINITION IN THE JUMP/LINK
C>                           TABLE HAS ITS OWN SET OF TABLE C OPERATORS
C>
C> USAGE:    CALL TABSUB (LUN, NEMO)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>     NEMO     - CHARACTER*8: TABLE A MNEMONIC
C>
C>    THIS ROUTINE CALLS:        BORT     INCTAB   IOKOPER   NEMTAB
C>                               NEMTBD   TABENT
C>    THIS ROUTINE IS CALLED BY: MAKESTAB
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE tabsub(LUN,NEMO)

      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