wrfv2_fire/var/external/bufr/makestab.inc

   1       SUBROUTINE MAKESTAB
   2
   3 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 !
   5 ! SUBPROGRAM:    MAKESTAB
   6 !   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 !
   8 ! ABSTRACT: THIS SUBROUTINE CONSTRUCTS AN INTERNAL JUMP/LINK TABLE
   9 !  WITHIN COMMON BLOCK /TABLES/, USING THE INFORMATION WITHIN THE
  10 !  INTERNAL BUFR TABLE ARRAYS (WITHIN COMMON BLOCK /TABABD/) FOR ALL OF
  11 !  THE LUN (I.E., I/O STREAM INDEX) VALUES THAT ARE CURRENTLY DEFINED TO
  12 !  THE BUFR ARCHIVE LIBRARY SOFTWARE.  NOTE THAT THE ENTIRE JUMP/LINK
  13 !  TABLE WILL ALWAYS BE COMPLETELY RECONSTRUCTED FROM SCRATCH, EVEN IF
  14 !  SOME OF THE INFORMATION WITHIN THE INTERNAL BUFR TABLE ARRAYS
  15 !  ALREADY EXISTED THERE AT THE TIME OF THE PREVIOUS CALL TO THIS
  16 !  SUBROUTINE, BECAUSE THERE MAY HAVE BEEN OTHER EVENTS THAT HAVE TAKEN
  17 !  PLACE SINCE THE PREVIOUS CALL TO THIS SUBROUTINE THAT HAVE NOT YET
  18 !  BEEN REFLECTED WITHIN THE INTERNAL JUMP/LINK TABLE, SUCH AS, E.G.
  19 !  THE UNLINKING OF AN LUN VALUE FROM THE BUFR ARCHIVE LIBRARY SOFTWARE
  20 !  VIA A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE CLOSBF.
  21 !
  22 ! PROGRAM HISTORY LOG:
  23 ! 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  24 ! 1995-06-28  J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE
  25 !                           ARRAYS IN ORDER TO HANDLE BIGGER FILES
  26 ! 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  27 !                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  28 !                           ROUTINE "BORT"
  29 ! 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  30 !                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  31 !                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  32 !                           BUFR FILES UNDER THE MPI)
  33 ! 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  34 ! 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  35 !                           INTERDEPENDENCIES
  36 ! 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  37 !                           INCREASED FROM 15000 TO 16000 (WAS IN
  38 !                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  39 !                           WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS
  40 !                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  41 !                           TERMINATES ABNORMALLY; NOW ALLOWS FOR THE
  42 !                           POSSIBILITY THAT A CONNECTED FILE MAY NOT
  43 !                           CONTAIN ANY DICTIONARY TABLE INFO (E.G.,
  44 !                           AN EMPTY FILE), SUBSEQUENT CONNECTED FILES
  45 !                           WHICH ARE NOT EMPTY WILL NO LONGER GET
  46 !                           TRIPPED UP BY THIS (THIS AVOIDS THE NEED
  47 !                           FOR AN APPLICATION PROGRAM TO DISCONNECT
  48 !                           ANY EMPTY FILES VIA A CALL TO CLOSBF)
  49 !
  50 ! USAGE:    CALL MAKESTAB
  51 !
  52 !   OUTPUT FILES:
  53 !     UNIT 06  - STANDARD OUTPUT PRINT
  54 !
  55 ! REMARKS:
  56 !    THIS ROUTINE CALLS:        BORT     CHEKSTAB STRCLN   TABSUB
  57 !    THIS ROUTINE IS CALLED BY: RDBFDX   RDUSDX
  58 !                               Normally not called by any application
  59 !                               programs.
  60 !
  61 ! ATTRIBUTES:
  62 !   LANGUAGE: FORTRAN 77
  63 !   MACHINE:  PORTABLE TO ALL PLATFORMS
  64 !
  65 !$$$
  66
  67       INCLUDE 'bufrlib.prm'
  68
  69       COMMON / QUIET / IPRT
  70       COMMON / STBFR / IOLUN (NFILES), IOMSG (NFILES)
  71 !     COMMON / USRINT / NVAL (NFILES), INV (MAXJL, NFILES), VAL (MAXJL, &
  72 !     NFILES)
  73       COMMON / TABABD / NTBA (0:NFILES), NTBB (0:NFILES), NTBD (0:      &
  74       NFILES), MTAB (MAXTBA, NFILES), IDNA (MAXTBA, NFILES, 2), IDNB (  &
  75       MAXTBB, NFILES), IDND (MAXTBD, NFILES), TABA (MAXTBA, NFILES),    &
  76       TABB (MAXTBB, NFILES), TABD (MAXTBD, NFILES)
  77 !     COMMON / TABLES / MAXTAB, NTAB, TAG (MAXJL), TYP (MAXJL), KNT (   &
  78 !     MAXJL), JUMP (MAXJL), LINK (MAXJL), JMPB (MAXJL), IBT (MAXJL),    &
  79 !     IRF (MAXJL), ISC (MAXJL), ITP (MAXJL), VALI (MAXJL), KNTI (MAXJL),&
  80 !     ISEQ (MAXJL, 2), JSEQ (MAXJL)
  81
  82       CHARACTER(600) TABD
  83       CHARACTER(128) TABB
  84       CHARACTER(128) TABA
  85       CHARACTER(128) BORT_STR
  86 !     CHARACTER(10) TAG
  87       CHARACTER(8) NEMO
  88 !     CHARACTER(3) TYP
  89       DIMENSION LUS (NFILES)
  90       LOGICAL EXPAND
  91 !     REAL(8) VAL
  92
  93 !-----------------------------------------------------------------------
  94 !-----------------------------------------------------------------------
  95
  96 !  RESET POINTER TABLE AND STRING CACHE
  97 !  ------------------------------------
  98
  99       NTAB = 0
 100       CALL STRCLN
 101
 102 !  FIGURE OUT WHICH UNITS SHARE TABLES
 103 !  -----------------------------------
 104
 105 !     First, determine how many LUN values are currently being used and,
 106 !     for each such one, whether it uses the same dictionary table
 107 !     information as any other LUN values that we have examined so far.
 108 !     If so, then set LUS(LUN) to a nonzero value.
 109
 110 !     Note that, for each LUN value, the MTAB(*,LUN) array contains
 111 !     pointer indices into the internal jump/link table for each of the
 112 !     Table A mnemonics that is currently defined for that LUN value.
 113 !     Thus, the code within the following DO loop is simply checking
 114 !     whether the first Table A mnemonic is the same for two different
 115 !     LUN values as the determination of whether those LUN values indeed
 116 !     share the same dictionary tables.
 117
 118       DO LUN = 1, NFILES
 119       LUS (LUN) = 0
 120       IF (IOLUN (LUN) .NE.0) THEN
 121       IF (LUN.GT.1) THEN
 122       DO LUM = 1, LUN - 1
 123 !ccccccc IF(MTAB(1,LUN).EQ.MTAB(1,LUM)) LUS(LUN) = LUM
 124       IF (MTAB (1, LUN) .EQ.MTAB (1, LUM) .AND.MTAB (1, LUM) .NE.0) LUS &
 125       (LUN) = LUM
 126       ENDDO
 127       ENDIF
 128       ENDIF
 129       ENDDO
 130
 131 !  INITIALIZE JUMP/LINK TABLES WITH SUBSETS/SEQUENCES/ELEMENTS
 132 !  -----------------------------------------------------------
 133
 134       DO LUN = 1, NFILES
 135
 136 !cccc IF(IOLUN(LUN).NE.0) THEN
 137       IF (IOLUN (LUN) .NE.0.AND.NTBA (LUN) .GT.0) THEN
 138
 139 !  RESET ANY EXISTING INVENTORY POINTERS
 140 !  -------------------------------------
 141
 142       IF (IOMSG (LUN) .NE.0) THEN
 143       IF (LUS (LUN) .EQ.0) INC = (NTAB + 1) - MTAB (1, LUN)
 144       IF (LUS (LUN) .NE.0) INC = MTAB (1, LUS (LUN) ) - MTAB (1, LUN)
 145       DO N = 1, NVAL (LUN)
 146       INV (N, LUN) = INV (N, LUN) + INC
 147       ENDDO
 148       ENDIF
 149
 150 !  CREATE NEW TABLE ENTRIES IF THIS UNIT DOESN'T SHARE EXISTING ONES
 151 !  -----------------------------------------------------------------
 152
 153       IF (LUS (LUN) .EQ.0) THEN
 154
 155 !     The dictionary table information corresponding to this LUN
 156 !     has not yet been written into the internal jump/link table,
 157 !     so add it in now.
 158
 159       CALL CHEKSTAB (LUN)
 160       DO ITBA = 1, NTBA (LUN)
 161       INOD = NTAB + 1
 162       NEMO = TABA (ITBA, LUN) (4:11)
 163       CALL TABSUB (LUN, NEMO)
 164       MTAB (ITBA, LUN) = INOD
 165       ISC (INOD) = NTAB
 166
 167 !**** note that the following lines are commented out****
 168 !ccc        DO N1=INOD,ISC(INOD)-1
 169 !ccc        DO N2=N1+1,ISC(INOD)
 170 !ccc        IF(TAG(N1).EQ.TAG(N2)) GOTO 900
 171 !ccc        ENDDO
 172 !ccc        ENDDO
 173 !********************************************************
 174
 175       ENDDO
 176       ENDIF
 177
 178       ENDIF
 179       ENDDO
 180
 181 !  STORE TYPES AND INITIAL VALUES AND COUNTS
 182 !  -----------------------------------------
 183
 184       DO NODE = 1, NTAB
 185       IF (TYP (NODE) .EQ.'SUB') THEN
 186       VALI (NODE) = 0
 187       KNTI (NODE) = 1
 188       ITP (NODE) = 0
 189       ELSEIF (TYP (NODE) .EQ.'SEQ') THEN
 190       VALI (NODE) = 0
 191       KNTI (NODE) = 1
 192       ITP (NODE) = 0
 193       ELSEIF (TYP (NODE) .EQ.'RPC') THEN
 194       VALI (NODE) = 0
 195       KNTI (NODE) = 0
 196       ITP (NODE) = 0
 197       ELSEIF (TYP (NODE) .EQ.'RPS') THEN
 198       VALI (NODE) = 0
 199       KNTI (NODE) = 0
 200       ITP (NODE) = 0
 201       ELSEIF (TYP (NODE) .EQ.'REP') THEN
 202 !     VALI (NODE) = BMISS
 203       VALI (NODE) = 2147483647
 204       KNTI (NODE) = IRF (NODE)
 205       ITP (NODE) = 0
 206       ELSEIF (TYP (NODE) .EQ.'DRS') THEN
 207       VALI (NODE) = 0
 208       KNTI (NODE) = 1
 209       ITP (NODE) = 1
 210       ELSEIF (TYP (NODE) .EQ.'DRP') THEN
 211       VALI (NODE) = 0
 212       KNTI (NODE) = 1
 213       ITP (NODE) = 1
 214       ELSEIF (TYP (NODE) .EQ.'DRB') THEN
 215       VALI (NODE) = 0
 216       KNTI (NODE) = 0
 217       ITP (NODE) = 1
 218       ELSEIF (TYP (NODE) .EQ.'NUM') THEN
 219 !     VALI (NODE) = BMISS
 220       VALI (NODE) = 2147483647
 221       KNTI (NODE) = 1
 222       ITP (NODE) = 2
 223       ELSEIF (TYP (NODE) .EQ.'CHR') THEN
 224 !     VALI (NODE) = BMISS
 225       VALI (NODE) = 2147483647
 226       KNTI (NODE) = 1
 227       ITP (NODE) = 3
 228       ELSE
 229       GOTO 901
 230       ENDIF
 231       ENDDO
 232
 233 !  SET UP EXPANSION SEGMENTS FOR TYPE 'SUB', 'DRP', AND 'DRS' NODES
 234 !  ----------------------------------------------------------------
 235
 236       NEWN = 0
 237
 238       DO N = 1, NTAB
 239       ISEQ (N, 1) = 0
 240       ISEQ (N, 2) = 0
 241       EXPAND = TYP (N) .EQ.'SUB'.OR.TYP (N) .EQ.'DRP'.OR.TYP (N)        &
 242       .EQ.'DRS'.OR.TYP (N) .EQ.'REP'.OR.TYP (N) .EQ.'DRB'
 243       IF (EXPAND) THEN
 244       ISEQ (N, 1) = NEWN + 1
 245       NODA = N
 246       NODE = N + 1
 247       DO K = 1, MAXJL
 248       KNT (K) = 0
 249       ENDDO
 250       IF (TYP (NODA) .EQ.'REP') KNT (NODE) = KNTI (NODA)
 251       IF (TYP (NODA) .NE.'REP') KNT (NODE) = 1
 252
 253     1 NEWN = NEWN + 1
 254       IF (NEWN.GT.MAXJL) GOTO 902
 255       JSEQ (NEWN) = NODE
 256       KNT (NODE) = MAX (KNTI (NODE), KNT (NODE) )
 257     2 IF (JUMP (NODE) * KNT (NODE) .GT.0) THEN
 258       NODE = JUMP (NODE)
 259       GOTO 1
 260       ELSEIF (LINK (NODE) .GT.0) THEN
 261       NODE = LINK (NODE)
 262       GOTO 1
 263       ELSE
 264       NODE = JMPB (NODE)
 265       IF (NODE.EQ.NODA) GOTO 3
 266       IF (NODE.EQ.0) GOTO 903
 267       KNT (NODE) = MAX (KNT (NODE) - 1, 0)
 268       GOTO 2
 269       ENDIF
 270     3 ISEQ (N, 2) = NEWN
 271       ENDIF
 272       ENDDO
 273
 274 !  PRINT THE SEQUENCE TABLES
 275 !  ------------------------
 276
 277       IF (IPRT.GE.2) THEN
 278       PRINT *
 279       PRINT * , '+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++&
 280      &++'
 281       PRINT *
 282       DO I = 1, NTAB
 283       PRINT 99, I, TAG (I), TYP (I), JMPB (I), JUMP (I), LINK (I),      &
 284       IBT (I), IRF (I), ISC (I)
 285       ENDDO
 286       PRINT *
 287    99 FORMAT   ('BUFRLIB: MAKESTAB ',I5,2X,A10,A5,6I8)
 288       PRINT * , '+++++++++++++++++BUFR ARCHIVE LIBRARY++++++++++++++++++&
 289      &++'
 290       PRINT *
 291       ENDIF
 292
 293 !  EXITS
 294 !  -----
 295
 296       RETURN
 297   900 WRITE (BORT_STR, '("BUFRLIB: MAKESTAB - MNEMONIC ",A," IS '//     &
 298       'DUPLICATED IN SUBSET: ",A)') NEMO, TAG (N1)
 299       CALL BORT (BORT_STR)
 300   901 WRITE (BORT_STR, '("BUFRLIB: MAKESTAB - UNKNOWN TYPE ",A)') TYP ( &
 301       NODE)
 302       CALL BORT (BORT_STR)
 303   902 WRITE (BORT_STR, '("BUFRLIB: MAKESTAB - NUMBER OF JSEQ ENTRIES IN'&
 304      &//' JUMP/LINK TABLE EXCEEDS THE LIMIT (",I6,")")') MAXJL
 305       CALL BORT (BORT_STR)
 306   903 WRITE (BORT_STR, '("BUFRLIB: MAKESTAB - NODE IS ZERO, FAILED TO '/&
 307      &/'CIRCULATE (TAG IS ",A,")")') TAG (N)
 308       CALL BORT (BORT_STR)
 309       END SUBROUTINE MAKESTAB