var/external/bufr/tabent.f

   1       SUBROUTINE TABENT(LUN,NEMO,TAB,ITAB,IREP,IKNT,JUM0)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    TABENT
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE BUILDS AND STORES AN ENTRY FOR A TABLE B OR
   9 C   TABLE D MNEMONIC (NEMO) WITHIN THE INTERNAL JUMP/LINK TABLE.
  10 C
  11 C PROGRAM HISTORY LOG:
  12 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  13 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  14 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  15 C                           ROUTINE "BORT"; CORRECTED SOME MINOR ERRORS
  16 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  17 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  18 C                           INTERDEPENDENCIES
  19 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  20 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  21 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  22 C                           WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS
  23 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  24 C                           TERMINATES ABNORMALLY
  25 C 2005-11-29  J. ATOR    -- ADDED SUPPORT FOR 207 AND 208 OPERATORS
  26 C 2010-03-19  J. ATOR    -- ADDED SUPPORT FOR 204 OPERATOR
  27 C 2012-03-02  J. ATOR    -- ADDED SUPPORT FOR 203 OPERATOR
  28 C
  29 C USAGE:    CALL TABENT (LUN, NEMO, TAB, ITAB, IREP, IKNT, JUM0)
  30 C   INPUT ARGUMENT LIST:
  31 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  32 C     NEMO     - CHARACTER*8: TABLE B OR D MNEMONIC TO STORE IN JUMP/
  33 C                LINK TABLE
  34 C     TAB      - CHARACTER*1: INTERNAL BUFR TABLE ARRAY ('B' OR 'D') IN
  35 C                WHICH NEMO IS DEFINED
  36 C     ITAB     - INTEGER: POSITIONAL INDEX OF NEMO WITHIN TAB
  37 C     IREP     - INTEGER: POSITIONAL INDEX WITHIN COMMON /REPTAB/
  38 C                ARRAYS, FOR USE WHEN NEMO IS REPLICATED:
  39 C                       0 = NEMO is not replicated
  40 C     IKNT     - INTEGER: NUMBER OF REPLICATIONS, FOR USE WHEN NEMO IS
  41 C                REPLICATED USING F=1 REGULAR (I.E., NON-DELAYED)
  42 C                REPLICATION:
  43 C                       0 = NEMO is not replicated using F=1 regular
  44 C                           (i.e., non-delayed) replication
  45 C     JUM0     - INTEGER: INDEX VALUE TO BE STORED FOR NEMO WITHIN
  46 C                INTERNAL JUMP/LINK TABLE ARRAY JMPB(*)
  47 C
  48 C REMARKS:
  49 C    THIS ROUTINE CALLS:        BORT     INCTAB   NEMTBB
  50 C    THIS ROUTINE IS CALLED BY: TABSUB
  51 C                               Normally not called by any application
  52 C                               programs.
  53 C
  54 C ATTRIBUTES:
  55 C   LANGUAGE: FORTRAN 77
  56 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  57 C
  58 C$$$
  59
  60       INCLUDE 'bufrlib.prm'
  61
  62 C     Note that the values within the COMMON /REPTAB/ arrays were
  63 C     initialized within subroutine BFRINI.
  64
  65       COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5)
  66
  67       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  68      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  69      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  70      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  71      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  72       COMMON /TABCCC/ ICDW,ICSC,ICRV,INCW
  73       COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV),
  74      .                ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV
  75
  76       CHARACTER*128 BORT_STR
  77       CHARACTER*24  UNIT
  78       CHARACTER*10  TAG,RTAG
  79       CHARACTER*8   NEMO,TAGNRV
  80       CHARACTER*3   TYP,TYPS,TYPT
  81       CHARACTER*1   REPS,TAB
  82
  83 C-----------------------------------------------------------------------
  84 C-----------------------------------------------------------------------
  85
  86 C  MAKE A JUMP/LINK TABLE ENTRY FOR A REPLICATOR
  87 C  ---------------------------------------------
  88
  89       IF(IREP.NE.0) THEN
  90          RTAG = REPS(IREP,1)//NEMO
  91          DO I=1,10
  92          IF(RTAG(I:I).EQ.' ') THEN
  93             RTAG(I:I) = REPS(IREP,2)
  94             CALL INCTAB(RTAG,TYPS(IREP,1),NODE)
  95             JUMP(NODE) = NODE+1
  96             JMPB(NODE) = JUM0
  97             LINK(NODE) = 0
  98             IBT (NODE) = LENS(IREP)
  99             IRF (NODE) = 0
 100             ISC (NODE) = 0
 101             IF(IREP.EQ.1) IRF(NODE) = IKNT
 102             JUM0 = NODE
 103             GOTO 1
 104          ENDIF
 105          ENDDO
 106          GOTO 900
 107       ENDIF
 108
 109 C  MAKE AN JUMP/LINK ENTRY FOR AN ELEMENT OR A SEQUENCE
 110 C  ----------------------------------------------------
 111
 112 1     IF(TAB.EQ.'B') THEN
 113
 114          CALL NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT)
 115          IF(UNIT(1:5).EQ.'CCITT') THEN
 116             TYPT = 'CHR'
 117          ELSE
 118             TYPT = 'NUM'
 119          ENDIF
 120          CALL INCTAB(NEMO,TYPT,NODE)
 121          JUMP(NODE) = 0
 122          JMPB(NODE) = JUM0
 123          LINK(NODE) = 0
 124          IBT (NODE) = IBIT
 125          IRF (NODE) = IREF
 126          ISC (NODE) = ISCL
 127          IF(UNIT(1:4).EQ.'CODE') THEN
 128             TYPT = 'COD'
 129          ELSEIF(UNIT(1:4).EQ.'FLAG') THEN
 130             TYPT = 'FLG'
 131          ENDIF
 132
 133          IF( (TYPT.EQ.'NUM') .AND. (IBTNRV.NE.0) ) THEN
 134
 135 C           This node contains a new (redefined) reference value.
 136
 137             IF(NNRV+1.GT.MXNRV) GOTO 902
 138             NNRV = NNRV+1
 139             TAGNRV(NNRV) = NEMO
 140             INODNRV(NNRV) = NODE
 141             ISNRV(NNRV) = NODE+1
 142             IBT(NODE) = IBTNRV
 143             IF(IPFNRV.EQ.0) IPFNRV = NNRV
 144          ELSEIF( (TYPT.EQ.'NUM') .AND. (NEMO(1:3).NE.'204') ) THEN
 145             IBT(NODE) = IBT(NODE) + ICDW
 146             ISC(NODE) = ISC(NODE) + ICSC
 147             IRF(NODE) = IRF(NODE) * ICRV
 148          ELSEIF( (TYPT.EQ.'CHR') .AND. (INCW.GT.0) ) THEN
 149             IBT(NODE) = INCW * 8
 150          ENDIF
 151
 152       ELSEIF(TAB.EQ.'D') THEN
 153
 154          IF(IREP.EQ.0) THEN
 155             TYPT = 'SEQ'
 156          ELSE
 157             TYPT = TYPS(IREP,2)
 158          ENDIF
 159          CALL INCTAB(NEMO,TYPT,NODE)
 160          JUMP(NODE) = NODE+1
 161          JMPB(NODE) = JUM0
 162          LINK(NODE) = 0
 163          IBT (NODE) = 0
 164          IRF (NODE) = 0
 165          ISC (NODE) = 0
 166
 167       ELSE
 168
 169          GOTO 901
 170
 171       ENDIF
 172
 173 C  EXITS
 174 C  -----
 175
 176       RETURN
 177 900   WRITE(BORT_STR,'("BUFRLIB: TABENT - REPLICATOR ERROR FOR INPUT '//
 178      . 'MNEMONIC ",A,", RTAG IS ",A)') NEMO,RTAG
 179       CALL BORT(BORT_STR)
 180 901   WRITE(BORT_STR,'("BUFRLIB: TABENT - UNDEFINED TAG (",A,") FOR '//
 181      . 'INPUT MNEMONIC ",A)') TAB,NEMO
 182       CALL BORT(BORT_STR)
 183 902   CALL BORT('BUFRLIB: TABENT - MXNRV OVERFLOW')
 184       END