var/external/bufr/tabsub.f

   1       SUBROUTINE TABSUB(LUN,NEMO)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    TABSUB
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE BUILDS THE ENTIRE JUMP/LINK TREE (I.E.,
   9 C   INCLUDING RECURSIVELY RESOLVING ALL "CHILD" MNEMONICS) FOR A TABLE
  10 C   A MNEMONIC (NEMO) WITHIN THE INTERNAL JUMP/LINK TABLE.
  11 C
  12 C PROGRAM HISTORY LOG:
  13 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  14 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  15 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  16 C                           ROUTINE "BORT"
  17 C 2000-09-19  J. WOOLLEN -- ADDED CAPABILITY TO ENCODE AND DECODE DATA
  18 C                           USING THE OPERATOR DESCRIPTORS (BUFR TABLE
  19 C                           C) FOR CHANGING WIDTH AND CHANGING SCALE
  20 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  21 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  22 C                           INTERDEPENDENCIES
  23 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  24 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  25 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  26 C                           WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS
  27 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  28 C                           TERMINATES ABNORMALLY
  29 C 2005-11-29  J. ATOR    -- ADDED SUPPORT FOR 207 AND 208 OPERATORS
  30 C 2012-03-02  J. ATOR    -- ADDED SUPPORT FOR 203 OPERATOR
  31 C 2012-04-19  J. ATOR    -- FIXED BUG FOR CASES WHERE A TABLE C OPERATOR
  32 C                           IMMEDIATELY FOLLOWS A TABLE D SEQUENCE
  33 C
  34 C USAGE:    CALL TABSUB (LUN, NEMO)
  35 C   INPUT ARGUMENT LIST:
  36 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  37 C     NEMO     - CHARACTER*8: TABLE A MNEMONIC
  38 C
  39 C REMARKS:
  40 C   -----------------------------------------------------------------
  41 C    EXAMPLE SHOWING CONTENTS OF INTERNAL JUMP/LINK TABLE (WITHIN
  42 C    COMMON /BTABLES/):
  43 C
  44 C      INTEGER MAXTAB = maximum number of jump/link table entries
  45 C
  46 C      INTEGER NTAB = actual number of jump/link table entries
  47 C                     currently in use
  48 C
  49 C      For I = 1, NTAB:
  50 C
  51 C      CHARACTER*10 TAG(I) = mnemonic
  52 C
  53 C      CHARACTER*3 TYP(I) = mnemonic type indicator:
  54 C         "SUB" if TAG(I) is a Table A mnemonic
  55 C         "SEQ" if TAG(I) is a Table D mnemonic using either short
  56 C               (i.e. 1-bit) delayed replication, F=1 regular (i.e.
  57 C               non-delayed) replication, or no replication at all
  58 C         "RPC" if TAG(I) is a Table D mnemonic using either medium
  59 C               (i.e. 8-bit) delayed replication or long (i.e. 16-bit)
  60 C               delayed replication
  61 C         "RPS" if TAG(I) is a Table D mnemonic using medium
  62 C               (i.e. 8-bit) delayed replication in a stack context
  63 C         "DRB" if TAG(I) denotes the short (i.e. 1-bit) delayed
  64 C               replication of a Table D mnemonic (which would then
  65 C               itself have its own separate entry in the jump/link
  66 C               table with a corresponding TAG value of "SEQ")
  67 C         "DRP" if TAG(I) denotes either the medium (i.e. 8-bit) or
  68 C               long (i.e. 16-bit) delayed replication of a Table D
  69 C               mnemonic (which would then itself have its own separate
  70 C               entry in the jump/link table with a corresponding TAG
  71 C               value of "RPC")
  72 C         "DRS" if TAG(I) denotes the medium (i.e. 8-bit) delayed
  73 C               replication, in a stack context, of a Table D mnemonic
  74 C               (which would then itself have its own separate entry
  75 C               in the jump/link table with a corresponding TAG value
  76 C               of "RPS")
  77 C         "REP" if TAG(I) denotes the F=1 regular (i.e. non-delayed)
  78 C               replication of a Table D mnemonic (which would then
  79 C               itself have its own separate entry in the jump/link
  80 C               table with a corresponding TAG value of "SEQ")
  81 C         "CHR" if TAG(I) is a Table B mnemonic with units "CCITT IA5"
  82 C         "NUM" if TAG(I) is a Table B mnemonic with any units other
  83 C               than "CCITT IA5"
  84 C
  85 C       INTEGER JMPB(I):
  86 C
  87 C       IF ( TYP(I) = "SUB" ) THEN
  88 C          JMPB(I) = 0
  89 C       ELSE IF ( ( TYP(I) = "SEQ" and TAG(I) uses either short (i.e.
  90 C                   1-bit) delayed replication or F=1 regular (i.e.
  91 C                   non-delayed) replication )
  92 C                OR
  93 C                 ( TYP(I) = "RPC" )  ) THEN
  94 C          JMPB(I) = the index of the jump/link table entry denoting
  95 C                    the replication of TAG(I)
  96 C       ELSE
  97 C          JMPB(I) = the index of the jump/link table entry for the
  98 C                    Table A or Table D mnemonic of which TAG(I) is a
  99 C                    child
 100 C       END IF
 101 C
 102 C       INTEGER JUMP(I):
 103 C
 104 C       IF ( ( TYP(I) = "CHR" )  OR  ( TYP(I) = "NUM" ) ) THEN
 105 C          JUMP(I) = 0
 106 C       ELSE IF ( ( TYP(I) = "DRB" ) OR
 107 C                 ( TYP(I) = "DRP" ) OR
 108 C                 ( TYP(I) = "REP" ) ) THEN
 109 C          JUMP(I) = the index of the jump/link table entry for the
 110 C                    Table D mnemonic whose replication is denoted by
 111 C                    TAG(I)
 112 C       ELSE
 113 C          JUMP(I) = the index of the jump/link table entry for the
 114 C                    Table B or Table D mnemonic which, sequentially,
 115 C                    is the first child of TAG(I)
 116 C       END IF
 117 C
 118 C       INTEGER LINK(I):
 119 C
 120 C       IF ( ( TYP(I) = "SEQ" and TAG(I) uses either short (i.e.
 121 C              1-bit) delayed replication or F=1 regular (i.e. non-
 122 C              delayed) replication )
 123 C           OR
 124 C            ( TYP(I) = "SUB" )
 125 C           OR
 126 C            ( TYP(I) = "RPC" ) ) THEN
 127 C              LINK(I) = 0
 128 C       ELSE IF ( TAG(I) is, sequentially, the last child Table B or
 129 C                 Table D mnemonic of the parent Table A or Table D
 130 C                 mnemonic indexed by JMPB(I) ) THEN
 131 C          LINK(I) = 0
 132 C       ELSE
 133 C          LINK(I) = the index of the jump/link table entry for the
 134 C                    Table B or Table D mnemonic which, sequentially,
 135 C                    is the next (i.e. following TAG(I)) child mnemonic
 136 C                    of the parent Table A or Table D mnemonic indexed
 137 C                    by JMPB(I)
 138 C       END IF
 139 C
 140 C       INTEGER IBT(I):
 141 C
 142 C       IF ( ( TYP(I) = "CHR" )  OR  ( TYP(I) = "NUM" ) ) THEN
 143 C          IBT(I) = bit width of Table B mnemonic TAG(I)
 144 C       ELSE IF ( ( TYP(I) = "DRB" )  OR  ( TYP(I) = "DRP" ) ) THEN
 145 C          IBT(I) = bit width of delayed descriptor replication factor
 146 C                   (i.e. 1, 8, or 16, depending on the replication
 147 C                   scheme denoted by TAG(I))
 148 C       ELSE
 149 C          IBT(I) = 0
 150 C       END IF
 151 C
 152 C       INTEGER IRF(I):
 153 C
 154 C       IF ( TYP(I) = "NUM" ) THEN
 155 C          IRF(I) = reference value of Table B mnemonic TAG(I)
 156 C       ELSE IF ( TYP(I) = "REP" ) THEN
 157 C          IRF(I) = number of F=1 regular (i.e. non-delayed)
 158 C                   replications of Table D mnemonic TAG(JUMP(I))
 159 C       ELSE
 160 C          IRF(I) = 0
 161 C       END IF
 162 C
 163 C       INTEGER ISC(I):
 164 C
 165 C       IF ( TYP(I) = "NUM" ) THEN
 166 C          ISC(I) = scale factor of Table B mnemonic TAG(I)
 167 C       ELSE IF ( TYP(I) = "SUB" ) THEN
 168 C          ISC(I) = the index of the jump/link table entry which,
 169 C                   sequentially, constitutes the last element of the
 170 C                   jump/link tree for Table A mnemonic TAG(I)
 171 C       ELSE
 172 C          ISC(I) = 0
 173 C       END IF
 174 C
 175 C   -----------------------------------------------------------------
 176 C
 177 C    THE FOLLOWING VALUES ARE STORED WITHIN COMMON /NRV203/ BY THIS
 178 C    SUBROUTINE, FOR USE WITH ANY 2-03-YYY (CHANGE REFERENCE VALUE)
 179 C    OPERATORS PRESENT WITHIN THE ENTIRE JUMP/LINK TABLE:
 180 C
 181 C      NNRV = number of nodes in the jump/link table which contain new
 182 C             reference values (as defined using the 2-03 operator)
 183 C
 184 C      INODNRV(I=1,NNRV) = nodes within jump/link table which contain
 185 C                          new reference values
 186 C
 187 C      NRV(I=1,NNRV) = new reference value corresponding to INODNRV(I)
 188 C
 189 C      TAGNRV(I=1,NNRV) = Table B mnemonic to which the new reference
 190 C                         value in NRV(I) applies
 191 C
 192 C      ISNRV(I=1,NNRV) = start of node range in jump/link table,
 193 C                        within which the new reference value defined
 194 C                        by NRV(I) will be applied to all occurrences
 195 C                        of TAGNRV(I)
 196 C
 197 C      IENRV(I=1,NNRV) = end of node range in jump/link table,
 198 C                        within which the new reference value defined
 199 C                        by NRV(I) will be applied to all occurrences
 200 C                        of TAGNRV(I)
 201 C
 202 C      IBTNRV = number of bits in Section 4 occupied by each new
 203 C               reference value for the current 2-03 operator
 204 C               (if IBTNRV = 0, then no 2-03 operator is currently
 205 C               in scope)
 206 C
 207 C      IPFNRV = a number between 1 and NNRV, denoting the first entry
 208 C               within the above arrays which applies to the current
 209 C               Table A mnemonic NEMO (if IPFNRV = 0, then no 2-03
 210 C               operators have been applied to NEMO)
 211 C
 212 C   -----------------------------------------------------------------
 213 C
 214 C    THIS ROUTINE CALLS:        BORT     INCTAB   NEMTAB   NEMTBD
 215 C                               TABENT
 216 C    THIS ROUTINE IS CALLED BY: MAKESTAB
 217 C                               Normally not called by any application
 218 C                               programs.
 219 C
 220 C ATTRIBUTES:
 221 C   LANGUAGE: FORTRAN 77
 222 C   MACHINE:  PORTABLE TO ALL PLATFORMS
 223 C
 224 C$$$
 225
 226       INCLUDE 'bufrlib.prm'
 227
 228       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
 229      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
 230      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
 231      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
 232      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
 233       COMMON /TABCCC/ ICDW,ICSC,ICRV,INCW
 234       COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV),
 235      .                ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV
 236
 237       CHARACTER*128 BORT_STR
 238       CHARACTER*10  TAG
 239       CHARACTER*8   NEMO,NEMS,NEM,TAGNRV
 240       CHARACTER*3   TYP
 241       CHARACTER*1   TAB
 242       DIMENSION     NEM(MAXCD,10),IRP(MAXCD,10),KRP(MAXCD,10)
 243       DIMENSION     DROP(10),JMP0(10),NODL(10),NTAG(10,2)
 244       LOGICAL       DROP
 245
 246       DATA MAXLIM /10/
 247
 248 C-----------------------------------------------------------------------
 249 C-----------------------------------------------------------------------
 250
 251 C  CHECK THE MNEMONIC
 252 C  ------------------
 253
 254 C     Note that Table A mnemonics, in addition to being stored within
 255 C     internal BUFR Table A array TABA(*,LUN), are also stored as
 256 C     Table D mnemonics within internal BUFR Table D array TABD(*,LUN).
 257 C     Thus, the following test is valid.
 258
 259       CALL NEMTAB(LUN,NEMO,IDN,TAB,ITAB)
 260       IF(TAB.NE.'D') GOTO 900
 261
 262 C  STORE A SUBSET NODE AND JUMP/LINK THE TREE
 263 C  ------------------------------------------
 264
 265       CALL INCTAB(NEMO,'SUB',NODE)
 266       JUMP(NODE) = NODE+1
 267       JMPB(NODE) = 0
 268       LINK(NODE) = 0
 269       IBT (NODE) = 0
 270       IRF (NODE) = 0
 271       ISC (NODE) = 0
 272
 273       CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,1),IRP(1,1),KRP(1,1))
 274       NTAG(1,1) = 1
 275       NTAG(1,2) = NSEQ
 276       JMP0(1)   = NODE
 277       NODL(1)   = NODE
 278       LIMB      = 1
 279
 280       ICDW = 0
 281       ICSC = 0
 282       ICRV = 1
 283       INCW = 0
 284
 285       IBTNRV = 0
 286       IPFNRV = 0
 287
 288 C  THIS LOOP RESOLVES ENTITIES IN A SUBSET BY EMULATING RECURSION
 289 C  --------------------------------------------------------------
 290
 291 1     DO N=NTAG(LIMB,1),NTAG(LIMB,2)
 292
 293       NTAG(LIMB,1) = N+1
 294       DROP(LIMB)   = N.EQ.NTAG(LIMB,2)
 295
 296       CALL NEMTAB(LUN,NEM(N,LIMB),IDN,TAB,ITAB)
 297       NEMS = NEM(N,LIMB)
 298
 299 C  SPECIAL TREATMENT FOR CERTAIN OPERATOR DESCRIPTORS (TAB=C)
 300 C  ----------------------------------------------------------
 301
 302       IF(TAB.EQ.'C') THEN
 303          READ(NEMS,'(3X,I3)') IYYY
 304          IF(ITAB.EQ.1) THEN
 305             IF(IYYY.NE.0) THEN
 306               IF(ICDW.NE.0) GOTO 907
 307               ICDW = IYYY-128
 308             ELSE
 309               ICDW = 0
 310             ENDIF
 311          ELSEIF(ITAB.EQ.2) THEN
 312             IF(IYYY.NE.0) THEN
 313               IF(ICSC.NE.0) GOTO 908
 314               ICSC = IYYY-128
 315             ELSE
 316               ICSC = 0
 317             ENDIF
 318          ELSEIF(ITAB.EQ.3) THEN
 319             IF(IYYY.EQ.0) THEN
 320
 321 C             Stop applying new reference values to subset nodes.
 322 C             Instead, revert to the use of standard Table B values.
 323
 324               IF(IPFNRV.EQ.0) GOTO 911
 325               DO JJ=IPFNRV,NNRV
 326                 IENRV(JJ) = NTAB
 327               ENDDO
 328               IPFNRV = 0
 329             ELSEIF(IYYY.EQ.255) THEN
 330
 331 C             End the definition of new reference values.
 332
 333               IBTNRV = 0
 334             ELSE
 335
 336 C             Begin the definition of new reference values.
 337
 338               IF(IBTNRV.NE.0) GOTO 909
 339               IBTNRV = IYYY
 340             ENDIF
 341          ELSEIF(ITAB.EQ.7) THEN
 342             IF(IYYY.GT.0) THEN
 343               IF(ICDW.NE.0) GOTO 907
 344               IF(ICSC.NE.0) GOTO 908
 345               ICDW = ((10*IYYY)+2)/3
 346               ICSC = IYYY
 347               ICRV = 10**IYYY
 348             ELSE
 349               ICSC = 0
 350               ICDW = 0
 351               ICRV = 1
 352             ENDIF
 353          ELSEIF(ITAB.EQ.8) THEN
 354             INCW = IYYY
 355          ENDIF
 356       ELSE
 357          NODL(LIMB) = NTAB+1
 358          IREP = IRP(N,LIMB)
 359          IKNT = KRP(N,LIMB)
 360          JUM0 = JMP0(LIMB)
 361          CALL TABENT(LUN,NEMS,TAB,ITAB,IREP,IKNT,JUM0)
 362       ENDIF
 363
 364       IF(TAB.EQ.'D') THEN
 365
 366 C        Note here how a new tree "LIMB" is created (and is then
 367 C        immediately recursively resolved) whenever a Table D mnemonic
 368 C        contains another Table D mnemonic as one of its children.
 369
 370          LIMB = LIMB+1
 371          IF(LIMB.GT.MAXLIM) GOTO 901
 372          CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,LIMB),IRP(1,LIMB),KRP(1,LIMB))
 373          NTAG(LIMB,1) = 1
 374          NTAG(LIMB,2) = NSEQ
 375          JMP0(LIMB)   = NTAB
 376          GOTO 1
 377       ELSEIF(DROP(LIMB)) THEN
 378 2        LINK(NODL(LIMB)) = 0
 379          LIMB = LIMB-1
 380          IF(LIMB.EQ.0 ) THEN
 381             IF(ICRV.NE.1) GOTO 904
 382             IF(ICDW.NE.0) GOTO 902
 383             IF(ICSC.NE.0) GOTO 903
 384             IF(INCW.NE.0) GOTO 905
 385             IF(IBTNRV.NE.0) GOTO 910
 386             IF(IPFNRV.NE.0) THEN
 387
 388 C             One or more new reference values were defined for this
 389 C             subset, but there was no subsequent 2-03-000 operator,
 390 C             so set all IENRV(*) values for this subset to point to
 391 C             the last element of the subset within the jump/link table.
 392 C             Note that, if there had been a subsequent 2-03-000
 393 C             operator, then these IENRV(*) values would have already
 394 C             been properly set above.
 395
 396               DO JJ=IPFNRV,NNRV
 397                 IENRV(JJ) = NTAB
 398               ENDDO
 399             ENDIF
 400             GOTO 100
 401          ENDIF
 402          IF(DROP(LIMB)) GOTO 2
 403          LINK(NODL(LIMB)) = NTAB+1
 404          GOTO 1
 405       ELSEIF(TAB.NE.'C') THEN
 406          LINK(NODL(LIMB)) = NTAB+1
 407       ENDIF
 408
 409       ENDDO
 410
 411       GOTO 906
 412
 413 C  EXITS
 414 C  -----
 415
 416 100   RETURN
 417 900   WRITE(BORT_STR,'("BUFRLIB: TABSUB - SUBSET NODE NOT IN TABLE D '//
 418      . '(TAB=",A,") FOR INPUT MNEMONIC ",A)') TAB,NEMO
 419       CALL BORT(BORT_STR)
 420 901   WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TOO MANY NESTED '//
 421      . 'TABLE D SEQUENCES (TREES) WITHIN INPUT MNEMONIC ",A," - THE '//
 422      . 'LIMIT IS",I4)') NEMO,MAXLIM
 423       CALL BORT(BORT_STR)
 424 902   WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-01-YYY OPERATOR WAS '//
 425      . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO
 426       CALL BORT(BORT_STR)
 427 903   WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-02-YYY OPERATOR WAS '//
 428      . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO
 429       CALL BORT(BORT_STR)
 430 904   WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-07-YYY OPERATOR WAS '//
 431      . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO
 432       CALL BORT(BORT_STR)
 433 905   WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-08-YYY OPERATOR WAS '//
 434      . 'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') NEMO
 435       CALL BORT(BORT_STR)
 436 906   WRITE(BORT_STR,'("BUFRLIB: TABSUB - ENTITIES WERE NOT '//
 437      . 'SUCCESSFULLY RESOLVED (BY EMULATING RESURSION) FOR SUBSET '//
 438      . 'DEFINED BY TBL A MNEM. ",A)') NEMO
 439       CALL BORT(BORT_STR)
 440 907   WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '//
 441      . 'CHANGE DATA WIDTH OPERATIONS IN THE TREE BUILT FROM INPUT ' //
 442      . 'MNEMONIC ",A)') NEMO
 443       CALL BORT(BORT_STR)
 444 908   WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '//
 445      . 'CHANGE DATA SCALE OPERATIONS IN THE TREE BUILT FROM INPUT ' //
 446      . 'MNEMONIC ",A)') NEMO
 447       CALL BORT(BORT_STR)
 448 909   WRITE(BORT_STR,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '//
 449      . 'CHANGE REF VALUE OPERATIONS IN THE TREE BUILT FROM INPUT ' //
 450      . 'MNEMONIC ",A)') NEMO
 451       CALL BORT(BORT_STR)
 452 910   WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-03-YYY OPERATOR WAS '//
 453      . 'APPLIED WITHOUT ANY SUBSEQUENT 2-03-255 OPERATOR FOR '//
 454      . 'INPUT MNEMONIC ",A)') NEMO
 455       CALL BORT(BORT_STR)
 456 911   WRITE(BORT_STR,'("BUFRLIB: TABSUB - A 2-03-000 OPERATOR WAS '//
 457      . 'ENCOUNTERED WITHOUT ANY PRIOR 2-03-YYY OPERATOR FOR '//
 458      . 'INPUT MNEMONIC ",A)') NEMO
 459       CALL BORT(BORT_STR)
 460       END