ufbtab.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE EITHER OPENS A BUFR FILE CONNECTED TO
C>   ABS(LUNIN) FOR INPUT OPERATIONS (IF IT IS NOT ALREADY OPENED AS
C>   SUCH), OR SAVES ITS POSITION AND REWINDS IT TO THE FIRST DATA
C>   MESSAGE (IF BUFR FILE ALREADY OPENED), THE EXTENT OF ITS PROCESSING
C>   IS DETERMINED BY THE SIGN OF LUNIN.  IF LUNIN IS GREATER THAN ZERO,
C>   THIS SUBROUTINE READS SPECIFIED VALUES FROM ALL DATA SUBSETS IN THE
C>   BUFR FILE INTO INTERNAL ARRAYS AND RETURNS THESE VALUES ALONG WITH
C>   A COUNT OF THE SUBSETS.  IF LUNIN IS LESS THAN ZERO, THIS
C>   SUBROUTINE RETURNS THE BUFR ARCHIVE LIBRARY'S GLOBAL VALUE FOR
C>   MISSING (REGARDLESS OF THE MNEMONICS SPECIFIED IN STR)
C>   ALONG WITH A COUNT OF THE SUBSETS (SEE REMARKS 2).  FINALLY, THIS
C>   SUBROUTINE EITHER CLOSES THE BUFR FILE IN ABS(LUNIN) (IF IT WAS
C>   OPENED HERE) OR RESTORES IT TO ITS PREVIOUS READ/WRITE STATUS AND
C>   POSITION (IF IT WAS NOT OPENED HERE).  WHEN LUNIN IS GREATER THAN
C>   ZERO, THE DATA VALUES CORRESPOND TO MNEMONICS, NORMALLY WHERE THERE
C>   IS NO REPLICATION (THERE CAN BE REGULAR OR DELAYED REPLICATION, BUT
C>   THIS SUBROUTINE WILL ONLY READ THE FIRST OCCURRENCE OF THE MNEMONIC
C>   IN EACH SUBSET).  UFBTAB PROVIDES A MECHANISM WHEREBY A USER CAN
C>   EITHER DO A QUICK SCAN OF THE RANGE OF VALUES CORRESPONDING TO ONE
C>   OR MORE MNEMNONICS AMONGST ALL DATA SUBSETS FOR AN ENTIRE BUFR FILE
C>   (WHEN LUNIN IS GREATER THAN ZERO), OR SIMPLY OBTAIN A COUNT OF
C>   SUBSETS IN THE BUFR FILE (WHEN LUNIN IS LESS THAN ZERO); NO OTHER
C>   BUFR ARCHIVE LIBRARY ROUTINES HAVE TO BE CALLED.  THIS SUBROUTINE
C>   IS SIMILAR TO BUFR ARCHIVE LIBRARY SUBROUTINE UFBTAM EXCEPT UFBTAM
C>   READS SUBSETS FROM MESSAGES STORED IN INTERNAL MEMORY AND IT HAS NO
C>   OPTION FOR RETURNING ONLY A COUNT OF THE SUBSETS.  IN ADDITION,
C>   UFBTAM CURRENTLY CANNOT READ DATA FROM COMPRESSED BUFR MESSAGES.
C>   UFBTAB CAN READ DATA FROM BOTH UNCOMPRESSED AND COMPRESSED BUFR
C>   MESSAGES.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1998-07-08  J. WOOLLEN -- IMPROVED MACHINE PORTABILITY
C> 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
C>                           LINING CODE WITH FPP DIRECTIVES
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           10,000 TO 20,000 BYTES
C> 2002-05-14  J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- MODIFIED TO NOT ABORT WHEN THERE ARE TOO
C>                           MANY SUBSETS COMING IN (I.E., .GT. "I2"),
C>                           BUT RATHER JUST PROCESS "I2" REPORTS AND
C>                           PRINT A DIAGNOSTIC; MAXJL (MAXIMUM NUMBER
C>                           OF JUMP/LINK ENTRIES) INCREASED FROM 15000
C>                           TO 16000 (WAS IN VERIFICATION VERSION);
C>                           MODIFIED TO CALL ROUTINE REWNBF WHEN THE
C>                           BUFR FILE IS ALREADY OPENED, ALLOWS
C>                           SPECIFIC SUBSET INFORMATION TO BE READ FROM
C>                           A FILE IN THE MIDST OF ITS BEING READ FROM
C>                           OR WRITTEN TO), BEFORE OPENBF WAS ALWAYS
C>                           CALLED AND THIS WOULD HAVE LED TO AN ABORT
C>                           OF THE APPLICATION PROGRAM (WAS IN
C>                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C>                           WRF; ADDED DOCUMENTATION (INCLUDING
C>                           HISTORY)
C> 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           20,000 TO 50,000 BYTES
C> 2005-09-16  J. WOOLLEN -- WORKS FOR COMPRESSED BUFR MESSAGES; ADDED
C>                           OPTION TO RETURN ONLY SUBSET COUNT (WHEN
C>                           INPUT UNIT NUMBER IS LESS THAN ZERO)
C> 2006-04-14  J. ATOR    -- ADD DECLARATION FOR CREF
C> 2007-01-19  J. ATOR    -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
C> 2009-04-21  J. ATOR    -- USE ERRWRT
C> 2009-12-01  J. ATOR    -- FIX BUG FOR COMPRESSED CHARACTER STRINGS
C>                           WHICH ARE IDENTICAL ACROSS ALL SUBSETS IN
C>                           A SINGLE MESSAGE
C> 2010-05-07  J. ATOR    -- WHEN CALLING IREADMG, TREAT READ ERROR AS
C>                           END-OF-FILE CONDITION
C> 2012-03-02  J. ATOR    -- USE FUNCTION UPS
C> 2012-09-15  J. WOOLLEN -- MODIFIED FOR C/I/O/BUFR INTERFACE;
C>                           USE NEW OPENBF TYPE 'INX' TO OPEN AND CLOSE
C>                           THE C FILE WITHOUT CLOSING THE FORTRAN FILE
C> 2014-11-20  J. ATOR    -- ENSURE OPENBF HAS BEEN CALLED AT LEAST ONCE
C>                           BEFORE CALLING STATUS
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> 2016-12-19  J. WOOLLEN -- FIX BUG TO PREVENT INVENTORY OVERFLOW
C>
C> USAGE:    CALL UFBTAB (LUNIN, TAB, I1, I2, IRET, STR)
C>   INPUT ARGUMENT LIST:
C>     LUNIN    - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER
C>                FOR BUFR FILE
C>     I1       - INTEGER:
C>                  - IF LUNIN IS GREATER THAN ZERO: LENGTH OF FIRST
C>                    DIMENSION OF TAB (MUST BE AT LEAST AS LARGE AS THE
C>                    NUMBER OF BLANK-SEPARATED MNEMONICS IN STR)
C>                  - IF LUNIN IS LESS THAN ZERO: LENGTH OF FIRST
C>                    DIMENSION OF TAB (RECOMMEND PASSING IN WITH VALUE
C>                    OF 1 - SEE REMARKS 2)
C>     I2       - INTEGER: LENGTH OF SECOND DIMENSION OF TAB
C>                  - IF LUNIN IS GREATER THAN ZERO: MUST BE AT LEAST AS
C>                    LARGE AS VALUE RETURNED IN IRET, OTHERWISE ONLY
C>                    FIRST I2 SUBSETS ARE RETURNED IN TAB
C>                  - IF LUNIN IS LESS THAN ZERO: RECOMMEND PASSING IN
C>                    WITH VALUE OF 1 - SEE REMARKS 2
C>     STR      - CHARACTER*(*):
C>                  - IF LUNIN IS GREATER THAN ZERO: STRING OF BLANK-
C>                    SEPARATED TABLE B MNEMONICS IN ONE-TO-ONE
C>                    CORRESPONDENCE WITH FIRST DIMENSION OF TAB, I1
C>                    (THE NUMBER OF MNEMONICS IN THE STRING MUST BE NO
C>                    LARGER THAN I1)
C>                      - THERE ARE THREE "GENERIC" MNEMONICS NOT
C>                        RELATED TO TABLE B, THESE RETURN THE FOLLOWING
C>                        INFORMATION IN CORRESPONDING TAB LOCATION:
C>                         'NUL'  WHICH ALWAYS RETURNS BMISS ("MISSING")
C>                         'IREC' WHICH ALWAYS RETURNS THE CURRENT BUFR
C>                                MESSAGE (RECORD) NUMBER IN WHICH THIS
C>                                SUBSET RESIDES
C>                         'ISUB' WHICH ALWAYS RETURNS THE CURRENT
C>                                SUBSET NUMBER OF THIS SUBSET WITHIN
C>                                THE BUFR MESSAGE (RECORD) NUMBER
C>                                'IREC'
C>                  - IF LUNIN IS LESS THAN ZERO: DUMMY {RECOMMEND
C>                    PASSING IN STRING AS A 1-CHARACTER BLANK (i.e.,
C>                    ' ') - SEE REMARKS 2}
C>
C>   OUTPUT ARGUMENT LIST:
C>     TAB      - REAL*8: (I1,I2):
C>                  - IF LUNIN IS GREATER THAN ZERO: STARTING ADDRESS OF
C>                    DATA VALUES READ FROM BUFR FILE
C>                  - IF LUNIN IS LESS THAN ZERO: STARTING ADDRESS OF
C>                    ARRAY OF VALUES ALL RETURNED WITH THE BUFRLIB'S
C>                    GLOBAL VALUE FOR MISSING (BMISS)
C>     IRET     - INTEGER: NUMBER OF DATA SUBSETS IN BUFR FILE
C>                  - IF LUNIN IS GREATER THAN ZERO: MUST BE NO LARGER
C>                    THAN I2, OTHERWISE ONLY FIRST I2 SUBSETS ARE
C>                    RETURNED IN TAB
C>
C> REMARKS:
C>    1) NOTE THAT UFBMEM CAN BE CALLED PRIOR TO THIS TO STORE THE BUFR
C>       MESSAGES INTO INTERNAL MEMORY.
C>
C>    2) BELOW ARE TWO EXAMPLES WHERE THE USER CALLS UFBTAB WITH LUNIN
C>       LESS THAN ZERO SO AS TO ONLY OBTAIN A COUNT OF SUBSETS IN A
C>       BUFR FILE (ALONG WITH THE BUFRLIB'S GLOBAL VALUE FOR
C>       "MISSING").
C>
C>       EXAMPLE 1) I1 AND I2 ARE SET TO 1 SUCH THAT TAB IS A SCALAR AND
C>          STR IS SET TO A 1-CHARACTER BLANK.  THESE ARE THE
C>          RECOMMENDED VALUES FOR I1, I2 AND STR SINCE THEY USE THE
C>          LEAST AMOUNT OF MEMORY):
C>
C>            REAL(8) TAB
C>                 ....
C>                 ....
C>            CALL UFBTAB(-LUNIN,TAB,1,1,IRET,' ')
C>                 ....
C>                 ....
C>
C>          HERE IRET WILL RETURN THE COUNT OF SUBSETS IN THE BUFR FILE
C>          AND TAB WILL RETURN THE BUFRLIB'S GLOBAL VALUE FOR "MISSING"
C>          (BMISS).
C>
C>       EXAMPLE 2) I1 IS SET TO 4 AND I2 IS SET TO 8 SUCH THAT TAB IS A
C>          32-WORD ARRAY, AND STR IS SET TO A NONSENSICAL STRING.
C>          THESE VALUES FOR I1, I2 AND STR WASTE MEMORY BUT GIVE THE
C>          SAME ANSWERS FOR TAB AND IRET AS IN EXAMPLE 1 (FOR THE SAME
C>          INPUT BUFR FILE!):
C>
C>            REAL(8) TAB(4,8)
C>                 ....
C>                 ....
C>            CALL UFBTAB(-LUNIN,TAB,4,8,IRET,'BUFR IS A WONDERFUL FMT')
C>                 ....
C>                 ....
C>
C>          HERE IRET WILL AGAIN RETURN THE COUNT OF SUBSETS IN THE BUFR
C>          FILE AND ALL 32 VALUES OF ARRAY TAB WILL RETURN THE
C>          BUFRLIB'S GLOBAL VALUE FOR "MISSING" (BMISS).
C>
C>       THE SIXTH ARGUMENT STR IS A DUMMY VALUE AND CAN BE SET TO
C>       ANY CHARACTER STRING (AGAIN, A 1-CHARACTER BLANK ' ' IS
C>       RECOMMENDED).  THE THIRD ARGUMENT I1 HAS NO RELATIONSHIP WITH
C>       THE NUMBER OF BLANK-SEPARATED MNEMONICS IN STR AND CAN BE SET
C>       TO ANY INTEGER VALUE (AGAIN, 1 IS RECOMMENDED).  THE FOURTH
C>       ARGUMENT I2 HAS NO RELATIONSHIP WITH THE NUMBER OF DATA SUBSETS
C>       IN THE BUFR FILE RETURNED IN IRET (AGAIN, 1 IS RECOMMENDED).
C>
C>.....................................................................
C>
C>    THIS ROUTINE CALLS:        BORT     CLOSBF   ERRWRT   IREADMG
C>                               IREADSB  MESGBC   NMSUB    OPENBF
C>                               PARSTR   REWNBF   STATUS   STRING
C>                               UPB      UPBB     UPC      UPS
C>                               USRTPL
C>    THIS ROUTINE IS CALLED BY: None
C>                               Normally called only by application
C>                               programs.
C>
      SUBROUTINE ufbtab(LUNIN,TAB,I1,I2,IRET,STR)

      USE modv_bmiss
      USE moda_usrint
      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_tables

      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
      COMMON /acmode/ iac
      COMMON /quiet / iprt

      CHARACTER*(*) str
      CHARACTER*128 bort_str,errstr
      CHARACTER*40  cref
      CHARACTER*10  tgs(100)
      CHARACTER*8   subset,cval
      equivalence(cval,rval)
      LOGICAL       openit,just_count
      REAL*8        tab(i1,i2),rval,ups

      DATA maxtg /100/

C-----------------------------------------------------------------------
      mps(node) = 2**(ibt(node))-1
      lps(lbit) = max(2**(lbit)-1,1)
C-----------------------------------------------------------------------

C  SET COUNTERS TO ZERO
C  --------------------

      iret = 0
      irec = 0
      isub = 0
      iacc = iac

C  CHECK FOR COUNT SUBSET ONLY OPTION (RETURNING THE BUFRLIB'S GLOBAL
C   VALUE FOR MISSING IN OUTPUT ARRAY) INDICATED BY NEGATIVE UNIT
C  ------------------------------------------------------------------

      lunit = abs(lunin)
      just_count = lunin.LT.lunit

C     Make sure OPENBF has been called at least once before trying to
C     call STATUS; otherwise, STATUS might try to access array space
C     that hasn't yet been dynamically allocated.
      CALL openbf(0,'FIRST',0)

      CALL status(lunit,lun,il,im)
      openit = il.EQ.0

      IF(openit) THEN

C  OPEN BUFR FILE CONNECTED TO UNIT LUNIT IF IT IS NOT ALREADY OPEN
C  ----------------------------------------------------------------

         CALL openbf(lunit,'INX',lunit)
      ELSE

C  IF BUFR FILE ALREADY OPENED, SAVE POSITION & REWIND TO FIRST DATA MSG
C  ---------------------------------------------------------------------

         CALL rewnbf(lunit,0)        
      ENDIF

      iac = 1

C  SET THE OUTPUT ARRAY VALUES TO THE BUFRLIB'S GLOBAL VALUE FOR
C   MISSING (BMISS)
C  -------------------------------------------------------------

      DO j=1,i2
      DO i=1,i1
      tab(i,j) = bmiss
      ENDDO
      ENDDO

      IF(just_count) THEN

C  COME HERE FOR COUNT ONLY OPTION (OUTPUT ARRAY VALUES REMAIN MISSING)
C  --------------------------------------------------------------------

         DO WHILE(ireadmg(-lunit,subset,idate).GE.0)
         iret = iret+nmsub(lunit)
         ENDDO
         goto 25
      ENDIF

C  OTHERWISE, CHECK FOR SPECIAL TAGS IN STRING
C  -------------------------------------------

      CALL parstr(str,tgs,maxtg,ntg,' ',.true.)
      DO i=1,ntg
      IF(tgs(i).EQ.'IREC') irec = i
      IF(tgs(i).EQ.'ISUB') isub = i
      ENDDO

C  READ A MESSAGE AND PARSE A STRING
C  ---------------------------------

10    IF(ireadmg(-lunit,subset,jdate).LT.0) goto 25
      CALL string(str,lun,i1,0)
      IF(irec.GT.0) nods(irec) = 0
      IF(isub.GT.0) nods(isub) = 0

C  PARSE THE MESSAGE DEPENDING ON WHETHER COMPRESSED OR NOT
C  --------------------------------------------------------

      CALL mesgbc(-lunit,mtyp,icmp)
      IF(icmp.EQ.0) THEN
         goto 15
      ELSEIF(icmp.EQ.1) then
         goto 115
      ELSE
         goto 900
      ENDIF

C  ---------------------------------------------
C  THIS BRANCH IS FOR UNCOMPRESSED MESSAGES
C  ---------------------------------------------
C  SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
C  ---------------------------------------------

15    IF(nsub(lun).EQ.msub(lun)) goto 10
      IF(iret+1.GT.i2) goto 99
      iret = iret+1

      DO i=1,nnod
      nods(i) = abs(nods(i))
      ENDDO

C  PARSE THE STRING NODES FROM A SUBSET
C  ------------------------------------

      mbit = mbyt(lun)*8 + 16
      nbit = 0
      n = 1
      CALL usrtpl(lun,n,n)
20    IF(n+1.LE.nval(lun)) THEN
         n = n+1
         node = inv(n,lun)
         mbit = mbit+nbit
         nbit = ibt(node)
         IF(itp(node).EQ.1) THEN
            CALL upbb(ival,nbit,mbit,mbay(1,lun))
            CALL usrtpl(lun,n,ival)
         ENDIF
         DO i=1,nnod
         IF(nods(i).EQ.node) THEN
            IF(itp(node).EQ.1) THEN
               CALL upbb(ival,nbit,mbit,mbay(1,lun))
               tab(i,iret) = ival
            ELSEIF(itp(node).EQ.2) THEN
               CALL upbb(ival,nbit,mbit,mbay(1,lun))
               IF(ival.LT.mps(node)) tab(i,iret) = ups(ival,node)
            ELSEIF(itp(node).EQ.3) THEN
               cval = ' '
               kbit = mbit
               CALL upc(cval,nbit/8,mbay(1,lun),kbit,.true.)
               tab(i,iret) = rval
            ENDIF
            nods(i) = -nods(i)
            goto 20
         ENDIF
         ENDDO
         DO i=1,nnod
         IF(nods(i).GT.0) goto 20
         ENDDO
      ENDIF

C  UPDATE THE SUBSET POINTERS BEFORE NEXT READ
C  -------------------------------------------

      ibit = mbyt(lun)*8
      CALL upb(nbyt,16,mbay(1,lun),ibit)
      mbyt(lun) = mbyt(lun) + nbyt
      nsub(lun) = nsub(lun) + 1
      IF(irec.GT.0) tab(irec,iret) = nmsg(lun)
      IF(isub.GT.0) tab(isub,iret) = nsub(lun)
      goto 15

C  ---------------------------------------------
C  THIS BRANCH IS FOR COMPRESSED MESSAGES
C  ---------------------------------------------
C  STORE ANY MESSAGE AND/OR SUBSET COUNTERS
C  ---------------------------------------------

C  CHECK ARRAY BOUNDS
C  ------------------

115   IF(iret+msub(lun).GT.i2) goto 99

C  STORE MESG/SUBS TOKENS
C  ----------------------

      IF(irec.GT.0.OR.isub.GT.0) THEN
         DO nsb=1,msub(lun)
         IF(irec.GT.0) tab(irec,iret+nsb) = nmsg(lun)
         IF(isub.GT.0) tab(isub,iret+nsb) = nsb
         ENDDO
      ENDIF

C  SETUP A NEW SUBSET TEMPLATE, PREPARE TO SUB-SURF
C  ------------------------------------------------

      CALL usrtpl(lun,1,1)
      ibit = mbyt(lun)
      n = 0

C  UNCOMPRESS CHOSEN NODES INTO THE TAB ARRAY (FIRST OCCURANCES ONLY)
C  ------------------------------------------------------------------

C  READ ELEMENTS LOOP
C  ------------------

120   DO n=n+1,nval(lun)
      node = inv(n,lun)
      nbit = ibt(node)
      ityp = itp(node)

C  FIRST TIME IN RESET NODE INDEXES, OR CHECK FOR NODE(S) STILL NEEDED
C  -------------------------------------------------------------------

      IF(n.EQ.1) THEN
         DO i=1,nnod
         nods(i) = abs(nods(i))
         ENDDO
      ELSE
         DO i=1,nnod
         IF(nods(i).GT.0) goto 125
         ENDDO
         goto 135
      ENDIF

C  FIND THE EXTENT OF THE NEXT SUB-GROUP
C  -------------------------------------

125   IF(ityp.EQ.1.OR.ityp.EQ.2) THEN
         CALL upb(lref,nbit,mbay(1,lun),ibit)
         CALL upb(linc,   6,mbay(1,lun),ibit)
         nibit = ibit + linc*msub(lun)
      ELSEIF(ityp.EQ.3) THEN
         cref=' '
         CALL upc(cref,nbit/8,mbay(1,lun),ibit,.true.)
         CALL upb(linc,   6,mbay(1,lun),ibit)
         nibit = ibit + 8*linc*msub(lun)
      ELSE
         goto 120
      ENDIF

C  PROCESS A TYPE1 NODE INTO NVAL
C  ------------------------------

      IF(ityp.EQ.1) THEN
         jbit = ibit + linc
         CALL upb(ninc,linc,mbay(1,lun),jbit)
         ival = lref+ninc
         CALL usrtpl(lun,n,ival)
         goto 120
      ENDIF

C  LOOP OVER STRING NODES
C  ----------------------

      DO i=1,nnod

C  CHOSEN NODES LOOP - KEEP TRACK OF NODES NEEDED AND NODES FOUND
C  --------------------------------------------------------------

      IF(node.NE.nods(i)) goto 130
      nods(i) = -nods(i)
      lret = iret

C  PROCESS A FOUND NODE INTO TAB
C  -----------------------------

      IF(ityp.EQ.1.OR.ityp.EQ.2) THEN
         DO nsb=1,msub(lun)
         jbit = ibit + linc*(nsb-1)
         CALL upb(ninc,linc,mbay(1,lun),jbit)
         ival = lref+ninc
         lret = lret+1
         IF(ninc.LT.lps(linc)) tab(i,lret) = ups(ival,node)
         ENDDO
      ELSEIF(ityp.EQ.3) THEN
         DO nsb=1,msub(lun)
         IF(linc.EQ.0) THEN
           cval = cref
         ELSE
           jbit = ibit + linc*(nsb-1)*8
           cval = ' '
           CALL upc(cval,linc,mbay(1,lun),jbit,.true.)
         ENDIF
         lret = lret+1
         tab(i,lret) = rval
         ENDDO
      ELSE
         CALL bort('UFBTAB - INVALID ELEMENT TYPE SPECIFIED')
      ENDIF

C  END OF LOOPS FOR COMPRESSED MESSAGE PARSING
C  -------------------------------------------

130   CONTINUE
      ENDDO
      ibit = nibit

C  END OF READ ELEMENTS LOOP
C  -------------------------

      ENDDO
135   iret = iret+msub(lun)

C  END OF MESSAGE PARSING - GO BACK FOR ANOTHER
C  --------------------------------------------

      goto 10

C  -------------------------------------------
C  ERROR PROCESSING AND EXIT ROUTES BELOW
C  -------------------------------------------
C  EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW
C  -------------------------------------------

99    nrep = iret
      DO WHILE(ireadsb(lunit).EQ.0)
      nrep = nrep+1
      ENDDO
      DO WHILE(ireadmg(-lunit,subset,jdate).GE.0)
      nrep = nrep+nmsub(lunit)
      ENDDO
      IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      WRITE ( unit=errstr, fmt='(A,A,I8,A,A)' )
     . 'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ',
     . .GT.'IS  LIMIT OF ', i2, ' IN THE 4TH ARG. (INPUT) - ',
     . 'INCOMPLETE READ'
      CALL errwrt(errstr)
      WRITE ( unit=errstr, fmt='(A,I8,A,I8,A)' )
     . '>>>UFBTAB STORED ', iret, ' REPORTS OUT OF ', nrep, '<<<'
      CALL errwrt(errstr)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
      ENDIF


25    IF(openit) THEN

C  CLOSE BUFR FILE IF IT WAS OPENED HERE
C  -------------------------------------

         CALL closbf(lunit)
      ELSE

C  RESTORE BUFR FILE TO PREV. STATUS & POSITION IF NOT ORIG. OPENED HERE
C  ---------------------------------------------------------------------

         CALL rewnbf(lunit,1)
      ENDIF

      iac = iacc

C  EXITS
C  -----

      RETURN
900   WRITE(bort_str,'("BUFRLIB: UFBTAB - INVALID COMPRESSION '//
     . 'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '//
     . 'ROUTINE MESGBC")') icmp
      CALL bort(bort_str)
      END