wrfv2_fire/var/external/bufr/ufbtab.inc

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