var/external/bufr/makestab.f

   1       SUBROUTINE MAKESTAB
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    MAKESTAB
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE
   9 C  WITHIN COMMON BLOCK /BTABLES/, USING THE INFORMATION WITHIN THE
  10 C  INTERNAL BUFR TABLE ARRAYS (WITHIN COMMON BLOCK /TABABD/) FOR ALL OF
  11 C  THE LUN (I.E., I/O STREAM INDEX) VALUES THAT ARE CURRENTLY DEFINED TO
  12 C  THE BUFR ARCHIVE LIBRARY SOFTWARE.  NOTE THAT THE ENTIRE JUMP/LINK
  13 C  TABLE WILL ALWAYS BE COMPLETELY RECONSTRUCTED FROM SCRATCH, EVEN IF
  14 C  SOME OF THE INFORMATION WITHIN THE INTERNAL BUFR TABLE ARRAYS
  15 C  ALREADY EXISTED THERE AT THE TIME OF THE PREVIOUS CALL TO THIS
  16 C  SUBROUTINE, BECAUSE THERE MAY HAVE BEEN OTHER EVENTS THAT HAVE TAKEN
  17 C  PLACE SINCE THE PREVIOUS CALL TO THIS SUBROUTINE THAT HAVE NOT YET
  18 C  BEEN REFLECTED WITHIN THE INTERNAL JUMP/LINK TABLE, SUCH AS, E.G.
  19 C  THE UNLINKING OF AN LUN VALUE FROM THE BUFR ARCHIVE LIBRARY SOFTWARE
  20 C  VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE CLOSBF.
  21 C
  22 C PROGRAM HISTORY LOG:
  23 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  24 C 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
  25 C                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
  26 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  27 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  28 C                           ROUTINE "BORT"
  29 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  30 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  31 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  32 C                           BUFR FILES UNDER THE MPI)
  33 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  34 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  35 C                           INTERDEPENDENCIES
  36 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  37 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  38 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  39 C                           WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS
  40 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  41 C                           TERMINATES ABNORMALLY; NOW ALLOWS FOR THE
  42 C                           POSSIBILITY THAT A CONNECTED FILE MAY NOT
  43 C                           CONTAIN ANY DICTIONARY TABLE INFO (E.G.,
  44 C                           AN EMPTY FILE), SUBSEQUENT CONNECTED FILES
  45 C                           WHICH ARE NOT EMPTY WILL NO LONGER GET
  46 C                           TRIPPED UP BY THIS (THIS AVOIDS THE NEED
  47 C                           FOR AN APPLICATION PROGRAM TO DISCONNECT
  48 C                           ANY EMPTY FILES VIA A CALL TO CLOSBF)
  49 C 2009-03-18  J. WOOLLEN -- ADDED LOGIC TO RESPOND TO THE CASES WHERE
  50 C                           AN INPUT FILE'S TABLES CHANGE IN MIDSTREAM.
  51 C                           THE NEW LOGIC MOSTLY ADDRESSES CASES WHERE
  52 C                           OTHER FILES ARE CONNECTED TO THE TABLES OF
  53 C                           THE FILE WHOSE TABLES HAVE CHANGED.
  54 C 2009-06-25  J. ATOR    -- TWEAK WOOLLEN LOGIC TO HANDLE SPECIAL CASE
  55 C                           WHERE TABLE WAS RE-READ FOR A PARTICULAR
  56 C                           LOGICAL UNIT BUT IS STILL THE SAME ACTUAL
  57 C                           TABLE AS BEFORE AND IS STILL SHARING THAT
  58 C                           TABLE WITH A DIFFERENT LOGICAL UNIT
  59 C 2009-11-17  J. ATOR    -- ADDED CHECK TO PREVENT WRITING OUT OF TABLE
  60 C                           INFORMATION WHEN A TABLE HAS BEEN RE-READ
  61 C                           WITHIN A SHARED LOGICAL UNIT BUT HASN'T
  62 C                           REALLY CHANGED
  63 C
  64 C USAGE:    CALL MAKESTAB
  65 C
  66 C REMARKS:
  67 C    THIS ROUTINE CALLS:        BORT     CHEKSTAB CLOSMG   CPBFDX
  68 C                               ERRWRT   ICMPDX   ISHRDX   STRCLN
  69 C                               TABSUB   WRDXTB
  70 C    THIS ROUTINE IS CALLED BY: RDBFDX   RDMEMM   RDUSDX   READDX
  71 C                               READERME READS3
  72 C                               Normally not called by any application
  73 C                               programs.
  74 C
  75 C ATTRIBUTES:
  76 C   LANGUAGE: FORTRAN 77
  77 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  78 C
  79 C$$$
  80
  81       INCLUDE 'bufrlib.prm'
  82
  83       COMMON /QUIET/  IPRT
  84       COMMON /STBFR/  IOLUN(NFILES),IOMSG(NFILES)
  85       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  86       COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
  87      .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
  88      .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
  89      .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
  90      .                TABD(MAXTBD,NFILES)
  91       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  92      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  93      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  94      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  95      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  96       COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV),
  97      .                ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV
  98       COMMON /LUSHR/  LUS(NFILES)
  99
 100       CHARACTER*600 TABD
 101       CHARACTER*128 TABB
 102       CHARACTER*128 TABA
 103       CHARACTER*128 BORT_STR,ERRSTR
 104       CHARACTER*10  TAG
 105       CHARACTER*8   NEMO,TAGNRV
 106       CHARACTER*3   TYP
 107       LOGICAL       EXPAND,XTAB(NFILES)
 108       REAL*8        VAL
 109
 110 C-----------------------------------------------------------------------
 111 C-----------------------------------------------------------------------
 112
 113 C  RESET POINTER TABLE AND STRING CACHE
 114 C  ------------------------------------
 115
 116       NTAB = 0
 117       NNRV = 0
 118       CALL STRCLN
 119
 120 C  FIGURE OUT WHICH UNITS SHARE TABLES
 121 C  -----------------------------------
 122
 123 C     The LUS array is static between calls to this subroutine, and it
 124 C     keeps track of which logical units share dictionary table
 125 C     information:
 126 C        if LUS(I) = 0, then IOLUN(I) does not share dictionary table
 127 C                       information with any other logical unit
 128 C        if LUS(I) > 0, then IOLUN(I) shares dictionary table
 129 C                       information with logical unit IOLUN(LUS(I))
 130 C        if LUS(I) < 0, then IOLUN(I) does not now, but at one point in
 131 C                       the past, shared dictionary table information
 132 C                       with logical unit IOLUN(ABS(LUS(I)))
 133
 134 C     The XTAB array is non-static and is recomputed within the below
 135 C     loop during each call to this subroutine:
 136 C        if XTAB(I) = .TRUE., then the dictionary table information
 137 C                             has changed for IOLUN(I) since the last
 138 C                             call to this subroutine
 139 C        if XTAB(I) = .FALSE., then the dictionary table information
 140 C                              has not changed for IOLUN(I) since the
 141 C                              last call to this subroutine
 142
 143       DO LUN=1,NFILES
 144         XTAB(LUN) = .FALSE.
 145         IF(IOLUN(LUN).EQ.0) THEN
 146
 147 C          Logical unit IOLUN(LUN) is not defined to the BUFRLIB.
 148
 149            LUS(LUN) = 0
 150         ELSE IF(MTAB(1,LUN).EQ.0) THEN
 151
 152 C          New dictionary table information has been read for logical
 153 C          unit IOLUN(LUN) since the last call to this subroutine.
 154
 155            XTAB(LUN) = .TRUE.
 156            IF(LUS(LUN).NE.0) THEN
 157              IF(IOLUN(ABS(LUS(LUN))).EQ.0) THEN
 158                LUS(LUN) = 0
 159              ELSE IF(LUS(LUN).GT.0) THEN
 160
 161 C              IOLUN(LUN) was sharing table information with logical
 162 C              unit IOLUN(LUS(LUN)), so check whether the table
 163 C              information has really changed.  If not, then IOLUN(LUN)
 164 C              just re-read a copy of the exact same table information
 165 C              as before, and therefore it can continue to share with
 166 C              logical unit IOLUN(LUS(LUN)).
 167
 168                IF(ICMPDX(LUS(LUN),LUN).EQ.1) THEN
 169                  XTAB(LUN) = .FALSE.
 170                  CALL CPBFDX(LUS(LUN),LUN)
 171                ELSE
 172                  LUS(LUN) = (-1)*LUS(LUN)
 173                ENDIF
 174              ELSE IF(ICMPDX(ABS(LUS(LUN)),LUN).EQ.1) THEN
 175
 176 C              IOLUN(LUN) was not sharing table information with logical
 177 C              unit IOLUN(LUS(LUN)), but it did at one point in the past
 178 C              and now once again has the same table information as that
 179 C              logical unit.  Since the two units shared table
 180 C              information at one point in the past, allow them to do
 181 C              so again.
 182
 183                XTAB(LUN) = .FALSE.
 184                LUS(LUN) = ABS(LUS(LUN))
 185                CALL CPBFDX(LUS(LUN),LUN)
 186              ENDIF
 187            ENDIF
 188         ELSE IF(LUS(LUN).GT.0) THEN
 189
 190 C          Logical unit IOLUN(LUN) is sharing table information with
 191 C          logical unit IOLUN(LUS(LUN)), so make sure that the latter
 192 C          unit is still defined to the BUFRLIB.
 193
 194            IF(IOLUN(LUS(LUN)).EQ.0) THEN
 195              LUS(LUN) = 0
 196            ELSE IF( XTAB(LUS(LUN)) .AND.
 197      +             (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN
 198
 199 C            The table information for logical unit IOLUN(LUS(LUN))
 200 C            just changed (in midstream).  If IOLUN(LUN) is an output
 201 C            file, then we will have to update it with the new table
 202 C            information later on in this subroutine.  Otherwise,
 203 C            IOLUN(LUN) is an input file and is no longer sharing
 204 C            tables with IOLUN(LUS(LUN)).
 205
 206              IF(IOLUN(LUN).LT.0) LUS(LUN) = (-1)*LUS(LUN)
 207            ENDIF
 208         ELSE
 209
 210 C          Determine whether logical unit IOLUN(LUN) is sharing table
 211 C          information with any other logical units.
 212
 213            LUM = 1
 214            DO WHILE ((LUM.LT.LUN).AND.(LUS(LUN).EQ.0))
 215               IF(ISHRDX(LUM,LUN).EQ.1) THEN
 216                  LUS(LUN) = LUM
 217               ELSE
 218                  LUM = LUM+1
 219               ENDIF
 220            ENDDO
 221         ENDIF
 222       ENDDO
 223
 224 C  INITIALIZE JUMP/LINK TABLES WITH SUBSETS/SEQUENCES/ELEMENTS
 225 C  -----------------------------------------------------------
 226
 227       DO LUN=1,NFILES
 228
 229        IF(IOLUN(LUN).NE.0 .AND. NTBA(LUN).GT.0) THEN
 230
 231 C        Reset any existing inventory pointers.
 232
 233          IF(IOMSG(LUN).NE.0) THEN
 234             IF(LUS(LUN).EQ.0) THEN
 235               INC = (NTAB+1)-MTAB(1,LUN)
 236             ELSE
 237               INC = MTAB(1,LUS(LUN))-MTAB(1,LUN)
 238             ENDIF
 239             DO N=1,NVAL(LUN)
 240               INV(N,LUN) = INV(N,LUN)+INC
 241             ENDDO
 242          ENDIF
 243
 244          IF(LUS(LUN).LE.0) THEN
 245
 246 C           The dictionary table information corresponding to logical
 247 C           unit IOLUN(LUN) has not yet been written into the internal
 248 C           jump/link table, so add it in now.
 249
 250             CALL CHEKSTAB(LUN)
 251             DO ITBA=1,NTBA(LUN)
 252               INOD = NTAB+1
 253               NEMO = TABA(ITBA,LUN)(4:11)
 254               CALL TABSUB(LUN,NEMO)
 255               MTAB(ITBA,LUN) = INOD
 256               ISC(INOD)      = NTAB
 257             ENDDO
 258          ELSE IF( XTAB(LUS(LUN)) .AND.
 259      +           (ICMPDX(LUS(LUN),LUN).EQ.0) ) THEN
 260
 261 C           Logical unit IOLUN(LUN) is an output file that is sharing
 262 C           table information with logical unit IOLUN(LUS(LUN)) whose
 263 C           table just changed (in midstream).  Flush any existing data
 264 C           messages from IOLUN(LUN), then update the table information
 265 C           for this logical unit with the corresponding new table
 266 C           information from IOLUN(LUS(LUN)), then update IOLUN(LUN)
 267 C           itself with a copy of the new table information.
 268
 269             LUNIT = ABS(IOLUN(LUN))
 270             IF(IOMSG(LUN).NE.0) CALL CLOSMG(LUNIT)
 271             CALL CPBFDX(LUS(LUN),LUN)
 272             LUNDX = ABS(IOLUN(LUS(LUN)))
 273             CALL WRDXTB(LUNDX,LUNIT)
 274          ENDIF
 275
 276        ENDIF
 277
 278       ENDDO
 279
 280 C  STORE TYPES AND INITIAL VALUES AND COUNTS
 281 C  -----------------------------------------
 282
 283       DO NODE=1,NTAB
 284       IF(TYP(NODE).EQ.'SUB') THEN
 285          VALI(NODE) = 0
 286          KNTI(NODE) = 1
 287          ITP (NODE) = 0
 288       ELSEIF(TYP(NODE).EQ.'SEQ') THEN
 289          VALI(NODE) = 0
 290          KNTI(NODE) = 1
 291          ITP (NODE) = 0
 292       ELSEIF(TYP(NODE).EQ.'RPC') THEN
 293          VALI(NODE) = 0
 294          KNTI(NODE) = 0
 295          ITP (NODE) = 0
 296       ELSEIF(TYP(NODE).EQ.'RPS') THEN
 297          VALI(NODE) = 0
 298          KNTI(NODE) = 0
 299          ITP (NODE) = 0
 300       ELSEIF(TYP(NODE).EQ.'REP') THEN
 301          VALI(NODE) = BMISS
 302          KNTI(NODE) = IRF(NODE)
 303          ITP (NODE) = 0
 304       ELSEIF(TYP(NODE).EQ.'DRS') THEN
 305          VALI(NODE) = 0
 306          KNTI(NODE) = 1
 307          ITP (NODE) = 1
 308       ELSEIF(TYP(NODE).EQ.'DRP') THEN
 309          VALI(NODE) = 0
 310          KNTI(NODE) = 1
 311          ITP (NODE) = 1
 312       ELSEIF(TYP(NODE).EQ.'DRB') THEN
 313          VALI(NODE) = 0
 314          KNTI(NODE) = 0
 315          ITP (NODE) = 1
 316       ELSEIF(TYP(NODE).EQ.'NUM') THEN
 317          VALI(NODE) = BMISS
 318          KNTI(NODE) = 1
 319          ITP (NODE) = 2
 320       ELSEIF(TYP(NODE).EQ.'CHR') THEN
 321          VALI(NODE) = BMISS
 322          KNTI(NODE) = 1
 323          ITP (NODE) = 3
 324       ELSE
 325          GOTO 901
 326       ENDIF
 327       ENDDO
 328
 329 C  SET UP EXPANSION SEGMENTS FOR TYPE 'SUB', 'DRP', AND 'DRS' NODES
 330 C  ----------------------------------------------------------------
 331
 332       NEWN = 0
 333
 334       DO N=1,NTAB
 335       ISEQ(N,1) = 0
 336       ISEQ(N,2) = 0
 337       EXPAND = TYP(N).EQ.'SUB' .OR. TYP(N).EQ.'DRP' .OR. TYP(N).EQ.'DRS'
 338      .                         .OR. TYP(N).EQ.'REP' .OR. TYP(N).EQ.'DRB'
 339       IF(EXPAND) THEN
 340          ISEQ(N,1) = NEWN+1
 341          NODA = N
 342          NODE = N+1
 343          DO K=1,MAXJL
 344          KNT(K) = 0
 345          ENDDO
 346          IF(TYP(NODA).EQ.'REP') KNT(NODE) = KNTI(NODA)
 347          IF(TYP(NODA).NE.'REP') KNT(NODE) = 1
 348
 349 1        NEWN = NEWN+1
 350          IF(NEWN.GT.MAXJL) GOTO 902
 351          JSEQ(NEWN) = NODE
 352          KNT(NODE) = MAX(KNTI(NODE),KNT(NODE))
 353 2        IF(JUMP(NODE)*KNT(NODE).GT.0) THEN
 354             NODE = JUMP(NODE)
 355             GOTO 1
 356          ELSE IF(LINK(NODE).GT.0) THEN
 357             NODE = LINK(NODE)
 358             GOTO 1
 359          ELSE
 360             NODE = JMPB(NODE)
 361             IF(NODE.EQ.NODA) GOTO 3
 362             IF(NODE.EQ.0   ) GOTO 903
 363             KNT(NODE) = MAX(KNT(NODE)-1,0)
 364             GOTO 2
 365          ENDIF
 366 3        ISEQ(N,2) = NEWN
 367       ENDIF
 368       ENDDO
 369
 370 C  PRINT THE SEQUENCE TABLES
 371 C  ------------------------
 372
 373       IF(IPRT.GE.2) THEN
 374       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 375          DO I=1,NTAB
 376            WRITE ( UNIT=ERRSTR, FMT='(A,I5,2X,A10,A5,6I8)' )
 377      .      'BUFRLIB: MAKESTAB ', I, TAG(I), TYP(I), JMPB(I), JUMP(I),
 378      .      LINK(I), IBT(I), IRF(I), ISC(I)
 379            CALL ERRWRT(ERRSTR)
 380          ENDDO
 381       CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
 382       CALL ERRWRT(' ')
 383       ENDIF
 384
 385 C  EXITS
 386 C  -----
 387
 388       RETURN
 389 900   WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - MNEMONIC ",A," IS '//
 390      . 'DUPLICATED IN SUBSET: ",A)') NEMO,TAG(N1)
 391       CALL BORT(BORT_STR)
 392 901   WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - UNKNOWN TYPE ",A)')TYP(NODE)
 393       CALL BORT(BORT_STR)
 394 902   WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - NUMBER OF JSEQ ENTRIES IN'//
 395      . ' JUMP/LINK TABLE EXCEEDS THE LIMIT (",I6,")")') MAXJL
 396       CALL BORT(BORT_STR)
 397 903   WRITE(BORT_STR,'("BUFRLIB: MAKESTAB - NODE IS ZERO, FAILED TO '//
 398      . 'CIRCULATE (TAG IS ",A,")")') TAG(N)
 399       CALL BORT(BORT_STR)
 400       END