var/external/bufr/ufbtab.f

   1       SUBROUTINE UFBTAB(LUNIN,TAB,I1,I2,IRET,STR)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    UFBTAB
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE EITHER OPENS A BUFR FILE CONNECTED TO
   9 C   ABS(LUNIN) FOR INPUT OPERATIONS (IF IT IS NOT ALREADY OPENED AS
  10 C   SUCH), OR SAVES ITS POSITION AND REWINDS IT TO THE FIRST DATA
  11 C   MESSAGE (IF BUFR FILE ALREADY OPENED), THE EXTENT OF ITS PROCESSING
  12 C   IS DETERMINED BY THE SIGN OF LUNIN.  IF LUNIN IS GREATER THAN ZERO,
  13 C   THIS SUBROUTINE READS SPECIFIED VALUES FROM ALL DATA SUBSETS IN THE
  14 C   BUFR FILE INTO INTERNAL ARRAYS AND RETURNS THESE VALUES ALONG WITH
  15 C   A COUNT OF THE SUBSETS.  IF LUNIN IS LESS THAN ZERO, THIS
  16 C   SUBROUTINE RETURNS THE BUFR ARCHIVE LIBRARY'S GLOBAL VALUE FOR
  17 C   MISSING (REGARDLESS OF THE MNEMONICS SPECIFIED IN STR)
  18 C   ALONG WITH A COUNT OF THE SUBSETS (SEE REMARKS 2).  FINALLY, THIS
  19 C   SUBROUTINE EITHER CLOSES THE BUFR FILE IN ABS(LUNIN) (IF IT WAS
  20 C   OPENED HERE) OR RESTORES IT TO ITS PREVIOUS READ/WRITE STATUS AND
  21 C   POSITION (IF IT WAS NOT OPENED HERE).  WHEN LUNIN IS GREATER THAN
  22 C   ZERO, THE DATA VALUES CORRESPOND TO MNEMONICS, NORMALLY WHERE THERE
  23 C   IS NO REPLICATION (THERE CAN BE REGULAR OR DELAYED REPLICATION, BUT
  24 C   THIS SUBROUTINE WILL ONLY READ THE FIRST OCCURRENCE OF THE MNEMONIC
  25 C   IN EACH SUBSET).  UFBTAB PROVIDES A MECHANISM WHEREBY A USER CAN
  26 C   EITHER DO A QUICK SCAN OF THE RANGE OF VALUES CORRESPONDING TO ONE
  27 C   OR MORE MNEMNONICS AMONGST ALL DATA SUBSETS FOR AN ENTIRE BUFR FILE
  28 C   (WHEN LUNIN IS GREATER THAN ZERO), OR SIMPLY OBTAIN A COUNT OF
  29 C   SUBSETS IN THE BUFR FILE (WHEN LUNIN IS LESS THAN ZERO); NO OTHER
  30 C   BUFR ARCHIVE LIBRARY ROUTINES HAVE TO BE CALLED.  THIS SUBROUTINE
  31 C   IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UFBTAM EXCEPT UFBTAM
  32 C   READS SUBSETS FROM MESSAGES STORED IN INTERNAL MEMORY AND IT HAS NO
  33 C   OPTION FOR RETURNING ONLY A COUNT OF THE SUBSETS.  IN ADDITION,
  34 C   UFBTAM CURRENTLY CANNOT READ DATA FROM COMPRESSED BUFR MESSAGES.
  35 C   UFBTAB CAN READ DATA FROM BOTH UNCOMPRESSED AND COMPRESSED BUFR
  36 C   MESSAGES.
  37 C
  38 C PROGRAM HISTORY LOG:
  39 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  40 C 1998-07-08  J. WOOLLEN -- IMPROVED MACHINE PORTABILITY
  41 C 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
  42 C                           LINING CODE WITH FPP DIRECTIVES
  43 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  44 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  45 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  46 C                           BUFR FILES UNDER THE MPI)
  47 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  48 C                           10,000 TO 20,000 BYTES
  49 C 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
  50 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  51 C                           INTERDEPENDENCIES
  52 C 2003-11-04  D. KEYSER  -- MODIFIED TO NOT ABORT WHEN THERE ARE TOO
  53 C                           MANY SUBSETS COMING IN (I.E., .GT. "I2"),
  54 C                           BUT RATHER JUST PROCESS "I2" REPORTS AND
  55 C                           PRINT A DIAGNOSTIC; MAXJL (MAXIMUM NUMBER
  56 C                           OF JUMP/LINK ENTRIES) INCREASED FROM 15000
  57 C                           TO 16000 (WAS IN VERIFICATION VERSION);
  58 C                           MODIFIED TO CALL ROUTINE REWNBF WHEN THE
  59 C                           BUFR FILE IS ALREADY OPENED, ALLOWS
  60 C                           SPECIFIC SUBSET INFORMATION TO BE READ FROM
  61 C                           A FILE IN THE MIDST OF ITS BEING READ FROM
  62 C                           OR WRITTEN TO), BEFORE OPENBF WAS ALWAYS
  63 C                           CALLED AND THIS WOULD HAVE LED TO AN ABORT
  64 C                           OF THE APPLICATION PROGRAM (WAS IN
  65 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  66 C                           WRF; ADDED DOCUMENTATION (INCLUDING
  67 C                           HISTORY)
  68 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  69 C                           20,000 TO 50,000 BYTES
  70 C 2005-09-16  J. WOOLLEN -- WORKS FOR COMPRESSED BUFR MESSAGES; ADDED
  71 C                           OPTION TO RETURN ONLY SUBSET COUNT (WHEN
  72 C                           INPUT UNIT NUMBER IS LESS THAN ZERO)
  73 C 2006-04-14  J. ATOR    -- ADD DECLARATION FOR CREF
  74 C 2007-01-19  J. ATOR    -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
  75 C 2009-04-21  J. ATOR    -- USE ERRWRT
  76 C 2009-12-01  J. ATOR    -- FIX BUG FOR COMPRESSED CHARACTER STRINGS
  77 C                           WHICH ARE IDENTICAL ACROSS ALL SUBSETS IN
  78 C                           A SINGLE MESSAGE
  79 C 2010-05-07  J. ATOR    -- WHEN CALLING IREADMG, TREAT READ ERROR AS
  80 C                           END-OF-FILE CONDITION
  81 C 2012-03-02  J. ATOR    -- USE FUNCTION UPS
  82 C 2012-09-15  J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE;
  83 C                           USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE
  84 C                           THE C FILE WITHOUT CLOSING THE FORTRAN FILE
  85 C
  86 C USAGE:    CALL UFBTAB (LUNIN, TAB, I1, I2, IRET, STR)
  87 C   INPUT ARGUMENT LIST:
  88 C     LUNIN    - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER
  89 C                FOR BUFR FILE
  90 C     I1       - INTEGER:
  91 C                  - IF LUNIN IS GREATER THAN ZERO: LENGTH OF FIRST
  92 C                    DIMENSION OF TAB OR THE NUMBER OF BLANK-SEPARATED
  93 C                    MNEMONICS IN STR, (FORMER MUST BE AT LEAST AS
  94 C                    LARGE AS LATTER)
  95 C                  - IF LUNIN IS LESS THAN ZERO: LENGTH OF FIRST
  96 C                    DIMENSION OF TAB (RECOMMEND PASSING IN WITH VALUE
  97 C                    OF 1 - SEE REMARKS 2)
  98 C     I2       - INTEGER: LENGTH OF SECOND DIMENSION OF TAB
  99 C                  - IF LUNIN IS GREATER THAN ZERO: MUST BE AT LEAST AS
 100 C                    LARGE AS VALUE RETURNED IN IRET, OTHERWISE ONLY
 101 C                    FIRST I2 SUBSETS ARE RETURNED IN TAB
 102 C                  - IF LUNIN IS LESS THAN ZERO: RECOMMEND PASSING IN
 103 C                    WITH VALUE OF 1 - SEE REMARKS 2
 104 C     STR      - CHARACTER*(*):
 105 C                  - IF LUNIN IS GREATER THAN ZERO: STRING OF BLANK-
 106 C                    SEPARATED TABLE B MNEMONICS IN ONE-TO-ONE
 107 C                    CORRESPONDENCE WITH FIRST DIMENSION OF TAB, I1
 108 C                    (THE NUMBER OF MNEMONICS IN THE STRING MUST BE NO
 109 C                    LARGER THAN I1)
 110 C                      - THERE ARE THREE "GENERIC" MNEMONICS NOT
 111 C                        RELATED TO TABLE B, THESE RETURN THE FOLLOWING
 112 C                        INFORMATION IN CORRESPONDING TAB LOCATION:
 113 C                         'NUL'  WHICH ALWAYS RETURNS BMISS ("MISSING")
 114 C                         'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR
 115 C                                MESSAGE (RECORD) NUMBER IN WHICH THIS
 116 C                                SUBSET RESIDES
 117 C                         'ISUB' WHICH ALWAYS RETURNS THE CURRENT
 118 C                                SUBSET NUMBER OF THIS SUBSET WITHIN
 119 C                                THE BUFR MESSAGE (RECORD) NUMBER
 120 C                                'IREC'
 121 C                  - IF LUNIN IS LESS THAN ZERO: DUMMY {RECOMMEND
 122 C                    PASSING IN STRING AS A 1-CHARACTER BLANK (i.e.,
 123 C                    ' ') - SEE REMARKS 2}
 124 C
 125 C   OUTPUT ARGUMENT LIST:
 126 C     TAB      - REAL*8: (I1,I2):
 127 C                  - IF LUNIN IS GREATER THAN ZERO: STARTING ADDRESS OF
 128 C                    DATA VALUES READ FROM BUFR FILE
 129 C                  - IF LUNIN IS LESS THAN ZERO: STARTING ADDRESS OF
 130 C                    ARRAY OF VALUES ALL RETURNED WITH THE BUFRLIB'S
 131 C                    GLOBAL VALUE FOR MISSING (BMISS)
 132 C     IRET     - INTEGER: NUMBER OF DATA SUBSETS IN BUFR FILE
 133 C                  - IF LUNIN IS GREATER THAN ZERO: MUST BE NO LARGER
 134 C                    THAN I2, OTHERWISE ONLY FIRST I2 SUBSETS ARE
 135 C                    RETURNED IN TAB
 136 C
 137 C REMARKS:
 138 C    1) NOTE THAT UFBMEM CAN BE CALLED PRIOR TO THIS TO STORE THE BUFR
 139 C       MESSAGES INTO INTERNAL MEMORY.
 140 C
 141 C    2) BELOW ARE TWO EXAMPLES WHERE THE USER CALLS UFBTAB WITH LUNIN
 142 C       LESS THAN ZERO SO AS TO ONLY OBTAIN A COUNT OF SUBSETS IN A
 143 C       BUFR FILE (ALONG WITH THE BUFRLIB'S GLOBAL VALUE FOR
 144 C       "MISSING").
 145 C
 146 C       EXAMPLE 1) I1 AND I2 ARE SET TO 1 SUCH THAT TAB IS A SCALAR AND
 147 C          STR IS SET TO A 1-CHARACTER BLANK.  THESE ARE THE
 148 C          RECOMMENDED VALUES FOR I1, I2 AND STR SINCE THEY USE THE
 149 C          LEAST AMOUNT OF MEMORY):
 150 C
 151 C            REAL(8) TAB
 152 C                 ....
 153 C                 ....
 154 C            CALL UFBTAB(-LUNIN,TAB,1,1,IRET,' ')
 155 C                 ....
 156 C                 ....
 157 C
 158 C          HERE IRET WILL RETURN THE COUNT OF SUBSETS IN THE BUFR FILE
 159 C          AND TAB WILL RETURN THE BUFRLIB'S GLOBAL VALUE FOR "MISSING"
 160 C          (BMISS).
 161 C
 162 C       EXAMPLE 2) I1 IS SET TO 4 AND I2 IS SET TO 8 SUCH THAT TAB IS A
 163 C          32-WORD ARRAY, AND STR IS SET TO A NONSENSICAL STRING.
 164 C          THESE VALUES FOR I1, I2 AND STR WASTE MEMORY BUT GIVE THE
 165 C          SAME ANSWERS FOR TAB AND IRET AS IN EXAMPLE 1 (FOR THE SAME
 166 C          INPUT BUFR FILE!):
 167 C
 168 C            REAL(8) TAB(4,8)
 169 C                 ....
 170 C                 ....
 171 C            CALL UFBTAB(-LUNIN,TAB,4,8,IRET,'BUFR IS A WONDERFUL FMT')
 172 C                 ....
 173 C                 ....
 174 C
 175 C          HERE IRET WILL AGAIN RETURN THE COUNT OF SUBSETS IN THE BUFR
 176 C          FILE AND ALL 32 VALUES OF ARRAY TAB WILL RETURN THE
 177 C          BUFRLIB'S GLOBAL VALUE FOR "MISSING" (BMISS).
 178 C
 179 C       THE SIXTH ARGUMENT STR IS A DUMMY VALUE AND CAN BE SET TO
 180 C       ANY CHARACTER STRING (AGAIN, A 1-CHARACTER BLANK ' ' IS
 181 C       RECOMMENDED).  THE THIRD ARGUMENT I1 HAS NO RELATIONSHIP WITH
 182 C       THE NUMBER OF BLANK-SEPARATED MNEMONICS IN STR AND CAN BE SET
 183 C       TO ANY INTEGER VALUE (AGAIN, 1 IS RECOMMENDED).  THE FOURTH
 184 C       ARGUMENT I2 HAS NO RELATIONSHIP WITH THE NUMBER OF DATA SUBSETS
 185 C       IN THE BUFR FILE RETURNED IN IRET (AGAIN, 1 IS RECOMMENDED).
 186 C
 187 C.....................................................................
 188 C
 189 C    THIS ROUTINE CALLS:        BORT     CLOSBF   ERRWRT   IREADMG
 190 C                               IREADSB  MESGBC   NMSUB    OPENBF
 191 C                               PARSTR   REWNBF   STATUS   STRING
 192 C                               UPB      UPBB     UPC      UPS
 193 C                               USRTPL
 194 C    THIS ROUTINE IS CALLED BY: None
 195 C                               Normally called only by application
 196 C                               programs.
 197 C
 198 C ATTRIBUTES:
 199 C   LANGUAGE: FORTRAN 77
 200 C   MACHINE:  PORTABLE TO ALL PLATFORMS
 201 C
 202 C$$$
 203
 204       INCLUDE 'bufrlib.prm'
 205
 206       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
 207      .                INODE(NFILES),IDATE(NFILES)
 208       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
 209      .                MBAY(MXMSGLD4,NFILES)
 210       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
 211       COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10)
 212       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
 213      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
 214      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
 215      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
 216      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
 217       COMMON /ACMODE/ IAC
 218       COMMON /QUIET / IPRT
 219
 220       CHARACTER*(*) STR
 221       CHARACTER*128 BORT_STR,ERRSTR
 222       CHARACTER*40  CREF
 223       CHARACTER*10  TAG,TGS(100)
 224       CHARACTER*8   SUBSET,CVAL
 225       CHARACTER*3   TYP
 226       EQUIVALENCE   (CVAL,RVAL)
 227       LOGICAL       OPENIT,JUST_COUNT
 228       REAL*8        VAL,TAB(I1,I2),RVAL,UPS
 229
 230       DATA MAXTG /100/
 231
 232 C-----------------------------------------------------------------------
 233       MPS(NODE) = 2**(IBT(NODE))-1
 234       LPS(LBIT) = MAX(2**(LBIT)-1,1)
 235 C-----------------------------------------------------------------------
 236
 237 C  SET COUNTERS TO ZERO
 238 C  --------------------
 239
 240       IRET = 0
 241       IREC = 0
 242       ISUB = 0
 243       IACC = IAC
 244
 245 C  CHECK FOR COUNT SUBSET ONLY OPTION (RETURNING THE BUFRLIB'S GLOBAL
 246 C   VALUE FOR MISSING IN OUTPUT ARRAY) INDICATED BY NEGATIVE UNIT
 247 C  ------------------------------------------------------------------
 248
 249       LUNIT = ABS(LUNIN)
 250       JUST_COUNT = LUNIN.LT.LUNIT
 251
 252       CALL STATUS(LUNIT,LUN,IL,IM)
 253       OPENIT = IL.EQ.0
 254
 255       IF(OPENIT) THEN
 256
 257 C  OPEN BUFR FILE CONNECTED TO UNIT LUNIT IF IT IS NOT ALREADY OPEN
 258 C  ----------------------------------------------------------------
 259
 260          CALL OPENBF(LUNIT,'INX',LUNIT)
 261       ELSE
 262
 263 C  IF BUFR FILE ALREADY OPENED, SAVE POSITION & REWIND TO FIRST DATA MSG
 264 C  ---------------------------------------------------------------------
 265
 266          CALL REWNBF(LUNIT,0)
 267       ENDIF
 268
 269       IAC = 1
 270
 271 C  SET THE OUTPUT ARRAY VALUES TO THE BUFRLIB'S GLOBAL VALUE FOR
 272 C   MISSING (BMISS)
 273 C  -------------------------------------------------------------
 274
 275       DO J=1,I2
 276       DO I=1,I1
 277       TAB(I,J) = BMISS
 278       ENDDO
 279       ENDDO
 280
 281       IF(JUST_COUNT) THEN
 282
 283 C  COME HERE FOR COUNT ONLY OPTION (OUTPUT ARRAY VALUES REMAIN MISSING)
 284 C  --------------------------------------------------------------------
 285
 286          DO WHILE(IREADMG(-LUNIT,SUBSET,IDATE).GE.0)
 287          IRET = IRET+NMSUB(LUNIT)
 288          ENDDO
 289          GOTO 25
 290       ENDIF
 291
 292 C  OTHERWISE, CHECK FOR SPECIAL TAGS IN STRING
 293 C  -------------------------------------------
 294
 295       CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.)
 296       DO I=1,NTG
 297       IF(TGS(I).EQ.'IREC') IREC = I
 298       IF(TGS(I).EQ.'ISUB') ISUB = I
 299       ENDDO
 300
 301 C  READ A MESSAGE AND PARSE A STRING
 302 C  ---------------------------------
 303
 304 10    IF(IREADMG(-LUNIT,SUBSET,JDATE).LT.0) GOTO 25
 305       CALL STRING(STR,LUN,I1,0)
 306       IF(IREC.GT.0) NODS(IREC) = 0
 307       IF(ISUB.GT.0) NODS(ISUB) = 0
 308
 309 C  PARSE THE MESSAGE DEPENDING ON WHETHER COMPRESSED OR NOT
 310 C  --------------------------------------------------------
 311
 312       CALL MESGBC(-LUNIT,MTYP,ICMP)
 313       IF(ICMP.EQ.0) THEN
 314          GOTO 15
 315       ELSEIF(ICMP.EQ.1) then
 316          GOTO 115
 317       ELSE
 318          GOTO 900
 319       ENDIF
 320
 321 C  ---------------------------------------------
 322 C  THIS BRANCH IS FOR UNCOMPRESSED MESSAGES
 323 C  ---------------------------------------------
 324 C  SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
 325 C  ---------------------------------------------
 326
 327 15    IF(NSUB(LUN).EQ.MSUB(LUN)) GOTO 10
 328       IF(IRET+1.GT.I2) GOTO 99
 329       IRET = IRET+1
 330
 331       DO I=1,NNOD
 332       NODS(I) = ABS(NODS(I))
 333       ENDDO
 334
 335 C  PARSE THE STRING NODES FROM A SUBSET
 336 C  ------------------------------------
 337
 338       MBIT = MBYT(LUN)*8 + 16
 339       NBIT = 0
 340       N = 1
 341       CALL USRTPL(LUN,N,N)
 342 20    IF(N+1.LE.NVAL(LUN)) THEN
 343          N = N+1
 344          NODE = INV(N,LUN)
 345          MBIT = MBIT+NBIT
 346          NBIT = IBT(NODE)
 347          IF(ITP(NODE).EQ.1) THEN
 348             CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN))
 349             CALL USRTPL(LUN,N,IVAL)
 350          ENDIF
 351          DO I=1,NNOD
 352          IF(NODS(I).EQ.NODE) THEN
 353             IF(ITP(NODE).EQ.1) THEN
 354                CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN))
 355                TAB(I,IRET) = IVAL
 356             ELSEIF(ITP(NODE).EQ.2) THEN
 357                CALL UPBB(IVAL,NBIT,MBIT,MBAY(1,LUN))
 358                IF(IVAL.LT.MPS(NODE)) TAB(I,IRET) = UPS(IVAL,NODE)
 359             ELSEIF(ITP(NODE).EQ.3) THEN
 360                CVAL = ' '
 361                KBIT = MBIT
 362                CALL UPC(CVAL,NBIT/8,MBAY(1,LUN),KBIT)
 363                TAB(I,IRET) = RVAL
 364             ENDIF
 365             NODS(I) = -NODS(I)
 366             GOTO 20
 367          ENDIF
 368          ENDDO
 369          DO I=1,NNOD
 370          IF(NODS(I).GT.0) GOTO 20
 371          ENDDO
 372       ENDIF
 373
 374 C  UPDATE THE SUBSET POINTERS BEFORE NEXT READ
 375 C  -------------------------------------------
 376
 377       IBIT = MBYT(LUN)*8
 378       CALL UPB(NBYT,16,MBAY(1,LUN),IBIT)
 379       MBYT(LUN) = MBYT(LUN) + NBYT
 380       NSUB(LUN) = NSUB(LUN) + 1
 381       IF(IREC.GT.0) TAB(IREC,IRET) = NMSG(LUN)
 382       IF(ISUB.GT.0) TAB(ISUB,IRET) = NSUB(LUN)
 383       GOTO 15
 384
 385 C  ---------------------------------------------
 386 C  THIS BRANCH IS FOR COMPRESSED MESSAGES
 387 C  ---------------------------------------------
 388 C  STORE ANY MESSAGE AND/OR SUBSET COUNTERS
 389 C  ---------------------------------------------
 390
 391 C  CHECK ARRAY BOUNDS
 392 C  ------------------
 393
 394 115   IF(IRET+MSUB(LUN).GT.I2) GOTO 99
 395
 396 C  STORE MESG/SUBS TOKENS
 397 C  ----------------------
 398
 399       IF(IREC.GT.0.OR.ISUB.GT.0) THEN
 400          DO NSB=1,MSUB(LUN)
 401          IF(IREC.GT.0) TAB(IREC,IRET+NSB) = NMSG(LUN)
 402          IF(ISUB.GT.0) TAB(ISUB,IRET+NSB) = NSB
 403          ENDDO
 404       ENDIF
 405
 406 C  SETUP A NEW SUBSET TEMPLATE, PREPARE TO SUB-SURF
 407 C  ------------------------------------------------
 408
 409       CALL USRTPL(LUN,1,1)
 410       IBIT = MBYT(LUN)
 411       N = 0
 412
 413 C  UNCOMPRESS CHOSEN NODES INTO THE TAB ARRAY (FIRST OCCURANCES ONLY)
 414 C  ------------------------------------------------------------------
 415
 416 C  READ ELEMENTS LOOP
 417 C  ------------------
 418
 419 120   DO N=N+1,NVAL(LUN)
 420       NODE = INV(N,LUN)
 421       NBIT = IBT(NODE)
 422       ITYP = ITP(NODE)
 423
 424 C  FIRST TIME IN RESET NODE INDEXES, OR CHECK FOR NODE(S) STILL NEEDED
 425 C  -------------------------------------------------------------------
 426
 427       IF(N.EQ.1) THEN
 428          DO I=1,NNOD
 429          NODS(I) = ABS(NODS(I))
 430          ENDDO
 431       ELSE
 432          DO I=1,NNOD
 433          IF(NODS(I).GT.0) GOTO 125
 434          ENDDO
 435          GOTO 135
 436       ENDIF
 437
 438 C  FIND THE EXTENT OF THE NEXT SUB-GROUP
 439 C  -------------------------------------
 440
 441 125   IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN
 442          CALL UPB(LREF,NBIT,MBAY(1,LUN),IBIT)
 443          CALL UPB(LINC,   6,MBAY(1,LUN),IBIT)
 444          NIBIT = IBIT + LINC*MSUB(LUN)
 445       ELSEIF(ITYP.EQ.3) THEN
 446          CREF=' '
 447          CALL UPC(CREF,NBIT/8,MBAY(1,LUN),IBIT)
 448          CALL UPB(LINC,   6,MBAY(1,LUN),IBIT)
 449          NIBIT = IBIT + 8*LINC*MSUB(LUN)
 450       ELSE
 451          GOTO 120
 452       ENDIF
 453
 454 C  LOOP OVER STRING NODES
 455 C  ----------------------
 456
 457       DO I=1,NNOD
 458
 459 C  CHOSEN NODES LOOP - KEEP TRACK OF NODES NEEDED AND NODES FOUND
 460 C  --------------------------------------------------------------
 461
 462       IF(NODE.NE.NODS(I)) GOTO 130
 463       NODS(I) = -NODS(I)
 464       LRET = IRET
 465
 466 C  PROCESS A FOUND NODE INTO TAB
 467 C  -----------------------------
 468
 469       IF(ITYP.EQ.1.OR.ITYP.EQ.2) THEN
 470          DO NSB=1,MSUB(LUN)
 471          JBIT = IBIT + LINC*(NSB-1)
 472          CALL UPB(NINC,LINC,MBAY(1,LUN),JBIT)
 473          IVAL = LREF+NINC
 474          LRET = LRET+1
 475          IF(NINC.LT.LPS(LINC)) TAB(I,LRET) = UPS(IVAL,NODE)
 476          ENDDO
 477       ELSEIF(ITYP.EQ.3) THEN
 478          DO NSB=1,MSUB(LUN)
 479          IF(LINC.EQ.0) THEN
 480            CVAL = CREF
 481          ELSE
 482            JBIT = IBIT + LINC*(NSB-1)*8
 483            CVAL = ' '
 484            CALL UPC(CVAL,LINC,MBAY(1,LUN),JBIT)
 485          ENDIF
 486          LRET = LRET+1
 487          TAB(I,LRET) = RVAL
 488          ENDDO
 489       ELSE
 490          CALL BORT('UFBTAB - INVALID ELEMENT TYPE SPECIFIED')
 491       ENDIF
 492
 493 C  END OF LOOPS FOR COMPRESSED MESSAGE PARSING
 494 C  -------------------------------------------
 495
 496 130   CONTINUE
 497       ENDDO
 498       IF(ITYP.EQ.1) CALL USRTPL(LUN,N,IVAL)
 499       IBIT = NIBIT
 500
 501 C  END OF READ ELEMENTS LOOP
 502 C  -------------------------
 503
 504       ENDDO
 505 135   IRET = IRET+MSUB(LUN)
 506
 507 C  END OF MESSAGE PARSING - GO BACK FOR ANOTHER
 508 C  --------------------------------------------
 509
 510       GOTO 10
 511
 512 C  -------------------------------------------
 513 C  ERROR PROCESSING AND EXIT ROUTES BELOW
 514 C  -------------------------------------------
 515 C  EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW
 516 C  -------------------------------------------
 517
 518 99    NREP = IRET
 519       DO WHILE(IREADSB(LUNIT).EQ.0)
 520       NREP = NREP+1
 521       ENDDO
 522       DO WHILE(IREADMG(-LUNIT,SUBSET,JDATE).GE.0)
 523       NREP = NREP+NMSUB(LUNIT)
 524       ENDDO
 525       IF(IPRT.GE.0) THEN
 526       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 527       WRITE ( UNIT=ERRSTR, FMT='(A,A,I8,A,A)' )
 528      . 'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ',
 529      . 'IS .GT. LIMIT OF ', I2, ' IN THE 4TH ARG. (INPUT) - ',
 530      . 'INCOMPLETE READ'
 531       CALL ERRWRT(ERRSTR)
 532       WRITE ( UNIT=ERRSTR, FMT='(A,I8,A,I8,A)' )
 533      . '>>>UFBTAB STORED ', IRET, ' REPORTS OUT OF ', NREP, '<<<'
 534       CALL ERRWRT(ERRSTR)
 535       CALL ERRWRT('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
 536       CALL ERRWRT(' ')
 537       ENDIF
 538
 539
 540 25    IF(OPENIT) THEN
 541
 542 C  CLOSE BUFR FILE IF IT WAS OPENED HERE
 543 C  -------------------------------------
 544
 545          CALL CLOSBF(LUNIT)
 546       ELSE
 547
 548 C  RESTORE BUFR FILE TO PREV. STATUS & POSITION IF NOT ORIG. OPENED HERE
 549 C  ---------------------------------------------------------------------
 550
 551          CALL REWNBF(LUNIT,1)
 552       ENDIF
 553
 554       IAC = IACC
 555
 556 C  EXITS
 557 C  -----
 558
 559       RETURN
 560 900   WRITE(BORT_STR,'("BUFRLIB: UFBTAB - INVALID COMPRESSION '//
 561      . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '//
 562      . 'ROUTINE MESGBC")') ICMP
 563       CALL BORT(BORT_STR)
 564       END