SUBROUTINE TABSUB(LUN,NEMO) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: TABSUB C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: 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 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 REMARKS: C ----------------------------------------------------------------- C EXAMPLE SHOWING CONTENTS OF INTERNAL JUMP/LINK TABLE (WITHIN C COMMON /BTABLES/): C C INTEGER MAXTAB = maximum number of jump/link table entries C C INTEGER NTAB = actual number of jump/link table entries C currently in use C C For I = 1, NTAB: C C CHARACTER*10 TAG(I) = mnemonic C C CHARACTER*3 TYP(I) = mnemonic type indicator: C "SUB" if TAG(I) is a Table A mnemonic C "SEQ" if TAG(I) is a Table D mnemonic using either short C (i.e. 1-bit) delayed replication, F=1 regular (i.e. C non-delayed) replication, or no replication at all C "RPC" if TAG(I) is a Table D mnemonic using either medium C (i.e. 8-bit) delayed replication or long (i.e. 16-bit) C delayed replication C "RPS" if TAG(I) is a Table D mnemonic using medium C (i.e. 8-bit) delayed replication in a stack context C "DRB" if TAG(I) denotes the short (i.e. 1-bit) delayed C replication of a Table D mnemonic (which would then C itself have its own separate entry in the jump/link C table with a corresponding TAG value of "SEQ") C "DRP" if TAG(I) denotes either the medium (i.e. 8-bit) or C long (i.e. 16-bit) delayed replication of a Table D C mnemonic (which would then itself have its own separate C entry in the jump/link table with a corresponding TAG C value of "RPC") C "DRS" if TAG(I) denotes the medium (i.e. 8-bit) delayed C replication, in a stack context, of a Table D mnemonic C (which would then itself have its own separate entry C in the jump/link table with a corresponding TAG value C of "RPS") C "REP" if TAG(I) denotes the F=1 regular (i.e. non-delayed) C replication of a Table D mnemonic (which would then C itself have its own separate entry in the jump/link C table with a corresponding TAG value of "SEQ") C "CHR" if TAG(I) is a Table B mnemonic with units "CCITT IA5" C "NUM" if TAG(I) is a Table B mnemonic with any units other C than "CCITT IA5" C C INTEGER JMPB(I): C C IF ( TYP(I) = "SUB" ) THEN C JMPB(I) = 0 C ELSE IF ( ( TYP(I) = "SEQ" and TAG(I) uses either short (i.e. C 1-bit) delayed replication or F=1 regular (i.e. C non-delayed) replication ) C OR C ( TYP(I) = "RPC" ) ) THEN C JMPB(I) = the index of the jump/link table entry denoting C the replication of TAG(I) C ELSE C JMPB(I) = the index of the jump/link table entry for the C Table A or Table D mnemonic of which TAG(I) is a C child C END IF C C INTEGER JUMP(I): C C IF ( ( TYP(I) = "CHR" ) OR ( TYP(I) = "NUM" ) ) THEN C JUMP(I) = 0 C ELSE IF ( ( TYP(I) = "DRB" ) OR C ( TYP(I) = "DRP" ) OR C ( TYP(I) = "REP" ) ) THEN C JUMP(I) = the index of the jump/link table entry for the C Table D mnemonic whose replication is denoted by C TAG(I) C ELSE C JUMP(I) = the index of the jump/link table entry for the C Table B or Table D mnemonic which, sequentially, C is the first child of TAG(I) C END IF C C INTEGER LINK(I): C C IF ( ( TYP(I) = "SEQ" and TAG(I) uses either short (i.e. C 1-bit) delayed replication or F=1 regular (i.e. non- C delayed) replication ) C OR C ( TYP(I) = "SUB" ) C OR C ( TYP(I) = "RPC" ) ) THEN C LINK(I) = 0 C ELSE IF ( TAG(I) is, sequentially, the last child Table B or C Table D mnemonic of the parent Table A or Table D C mnemonic indexed by JMPB(I) ) THEN C LINK(I) = 0 C ELSE C LINK(I) = the index of the jump/link table entry for the C Table B or Table D mnemonic which, sequentially, C is the next (i.e. following TAG(I)) child mnemonic C of the parent Table A or Table D mnemonic indexed C by JMPB(I) C END IF C C INTEGER IBT(I): C C IF ( ( TYP(I) = "CHR" ) OR ( TYP(I) = "NUM" ) ) THEN C IBT(I) = bit width of Table B mnemonic TAG(I) C ELSE IF ( ( TYP(I) = "DRB" ) OR ( TYP(I) = "DRP" ) ) THEN C IBT(I) = bit width of delayed descriptor replication factor C (i.e. 1, 8, or 16, depending on the replication C scheme denoted by TAG(I)) C ELSE C IBT(I) = 0 C END IF C C INTEGER IRF(I): C C IF ( TYP(I) = "NUM" ) THEN C IRF(I) = reference value of Table B mnemonic TAG(I) C ELSE IF ( TYP(I) = "REP" ) THEN C IRF(I) = number of F=1 regular (i.e. non-delayed) C replications of Table D mnemonic TAG(JUMP(I)) C ELSE C IRF(I) = 0 C END IF C C INTEGER ISC(I): C C IF ( TYP(I) = "NUM" ) THEN C ISC(I) = scale factor of Table B mnemonic TAG(I) C ELSE IF ( TYP(I) = "SUB" ) THEN C ISC(I) = the index of the jump/link table entry which, C sequentially, constitutes the last element of the C jump/link tree for Table A mnemonic TAG(I) C ELSE C ISC(I) = 0 C END IF C C ----------------------------------------------------------------- C C THE FOLLOWING VALUES ARE STORED WITHIN COMMON /NRV203/ BY THIS C SUBROUTINE, FOR USE WITH ANY 2-03-YYY (CHANGE REFERENCE VALUE) C OPERATORS PRESENT WITHIN THE ENTIRE JUMP/LINK TABLE: C C NNRV = number of nodes in the jump/link table which contain new C reference values (as defined using the 2-03 operator) C C INODNRV(I=1,NNRV) = nodes within jump/link table which contain C new reference values C C NRV(I=1,NNRV) = new reference value corresponding to INODNRV(I) C C TAGNRV(I=1,NNRV) = Table B mnemonic to which the new reference C value in NRV(I) applies C C ISNRV(I=1,NNRV) = start of node range in jump/link table, C within which the new reference value defined C by NRV(I) will be applied to all occurrences C of TAGNRV(I) C C IENRV(I=1,NNRV) = end of node range in jump/link table, C within which the new reference value defined C by NRV(I) will be applied to all occurrences C of TAGNRV(I) C C IBTNRV = number of bits in Section 4 occupied by each new C reference value for the current 2-03 operator C (if IBTNRV = 0, then no 2-03 operator is currently C in scope) C C IPFNRV = a number between 1 and NNRV, denoting the first entry C within the above arrays which applies to the current C Table A mnemonic NEMO (if IPFNRV = 0, then no 2-03 C operators have been applied to NEMO) C C ----------------------------------------------------------------- C C THIS ROUTINE CALLS: BORT INCTAB NEMTAB NEMTBD C TABENT C THIS ROUTINE IS CALLED BY: MAKESTAB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), . ISEQ(MAXJL,2),JSEQ(MAXJL) COMMON /TABCCC/ ICDW,ICSC,ICRV,INCW COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV), . ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV CHARACTER*128 BORT_STR CHARACTER*10 TAG CHARACTER*8 NEMO,NEMS,NEM,TAGNRV CHARACTER*3 TYP CHARACTER*1 TAB DIMENSION NEM(MAXCD,10),IRP(MAXCD,10),KRP(MAXCD,10) DIMENSION DROP(10),JMP0(10),NODL(10),NTAG(10,2) LOGICAL DROP 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 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 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) END