ufbtab.f

Go to the documentation of this file.

C> @file
C> @brief Read one or more data values from every data subset in a
C> BUFR file
 
C> This subroutine reads through every data subset in a BUFR file
C> and returns one or more specified data values from each subset.
C>
C> <p>This provides a useful way to scan the ranges of one or more
C> specified data values across an entire BUFR file. 
C>
C> @author J. Woollen
C> @date 1994-01-06
C>      
C> @param[in] LUNIN   -- integer: Absolute value is Fortran logical
C>                       unit number for BUFR file
C> @param[out] TAB    -- real*8(*,*): Data values
C> @param[in] I1 -- integer: Actual first dimension of TAB as allocated
C>                  within the calling program
C> @param[in] I2 -- integer: Actual second dimension of TAB as allocated
C>                  within the calling program
C> @param[out] IRET -- integer: Number of data subsets in BUFR file
C> @param[in] STR -- character*(*): String of blank-separated
C>                   Table B mnemonics, in one-to-one correspondence
C>                   with the number of data values that will be read
C>                   from each data subset within the first dimension of
C>                   TAB (see [DX BUFR Tables](@ref dfbftab) for further
C>                   information about Table B mnemonics)
C>
C> <p>It is the user's responsibility to ensure that TAB is dimensioned
C> sufficiently large enough to accommodate the number of data values
C> that are to be read from the BUFR file.  Specifically, each row of
C> TAB will contain the data values read from a different data subset,
C> so the value I2 must be at least as large as the total number of data
C> subsets in the BUFR file.
C>
C> <p>If logical unit ABS(LUNIN) has already been opened
C> via a previous call to subroutine openbf(), then this subroutine
C> will save the current file position, rewind the file to the
C> beginning, read through the entire file, and then restore it to its
C> previous file position.  Otherwise, if logical unit ABS(LUNIN) has
C> not already been opened via a previous call to subroutine openbf(),
C> then this subroutine will open it via an internal call to
C> subroutine openbf(), read through the entire file, and then close
C> it via an internal call to subroutine closbf().
C>
C> @remarks
C> - If LUNIN < 0, the number of data subsets in the BUFR file will
C> still be returned in IRET; however, STR will be ignored,
C> and all of the values returned in TAB will contain the current
C> placeholder value for "missing" data.
C> - If any of the Table B mnemonics in STR are replicated within the
C> data subset definition for the BUFR file, then this subroutine will
C> only return the value corresponding to the first occurrence of each
C> such mnemonic (counting from the beginning of the data subset
C> definition) within the corresponding row of TAB.
C>
C> <b>Program history log:</b>
C> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 1994-01-06 | J. Woollen | Original author |
C> | 1998-07-08 | J. Woollen | Replaced call to Cray library routine "ABORT" with call to new internal routine bort() |
C> | 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32 |
C> | 2000-09-19 | J. Woollen | Maximum length increased from 10,000 to 20,000 bytes |
C> | 2002-05-14 | J. Woollen | Removed old Cray compiler directives |
C> | 2003-11-04 | D. Keyser  | Modified to not abort when there are more than I2 data subsets, but instead just process first I2 subsets and print a diagnostic |
C> | 2003-11-04 | D. Keyser  | Increased MAXJL from 15000 to 16000; modified to use rewnbf(); upgraded to allow reading from a file that has already been opened via openbf() |
C> | 2004-08-09 | J. Ator    | Maximum message length increased from 20,000 to 50,000 bytes |
C> | 2005-09-16 | J. Woollen | upgraded to work for compressed BUFR messages, and to allow for LUNIN < 0 option |
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 which are identical across all subsets in a single messagE |
C> | 2010-05-07 | J. Ator    | When calling ireadmg(), treat read error as EOF condition |
C> | 2012-03-02 | J. Ator    | Use function ups() |
C> | 2012-09-15 | J. Woollen | Modified for C/I/O/BUFR interface; added IO type 'INX' to enable open and close for C file without closing FORTRAN file |
C> | 2014-11-20 | J. Ator    | Ensure openbf() has been called at least once 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> | 2022-05-06 | J. Woollen | Use up8 and upb8 for 8byte integers, use nbmp for usrtpl, add msgunp=1 option |
C>
      SUBROUTINE ufbtab(LUNIN,TAB,I1,I2,IRET,STR)
 
      USE modv_bmiss
      USE moda_usrint
      USE moda_msgcwd
      USE moda_unptyp
      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)
      integer*8     ival,lref,ninc,mps,lps
      LOGICAL       OPENIT,JUST_COUNT
      real*8        tab(i1,i2),rval,ups
 
      DATA maxtg /100/
 
C-----------------------------------------------------------------------
      mps(node) = 2_8**(ibt(node))-1
      lps(lbit) = max(2_8**(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  --------------------------------------------------------
 
      if(msgunp(lun)==2) goto 115 
 
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  ------------------------------------
 
      if(msgunp(lun)==0) mbit = mbyt(lun)*8 + 16
      if(msgunp(lun)==1) mbit = mbyt(lun)
 
      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 upb8(ival,nbit,mbit,mbay(1,lun))
            nbmp=ival; CALL usrtpl(lun,n,nbmp)
         ENDIF
         DO i=1,nnod
         IF(nods(i).EQ.node) THEN
            IF(itp(node).EQ.1) THEN
               CALL upb8(ival,nbit,mbit,mbay(1,lun))
               tab(i,iret) = ival
            ELSEIF(itp(node).EQ.2) THEN
               CALL upb8(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  -------------------------------------------
 
      if(msgunp(lun)==0) then
         ibit = mbyt(lun)*8
         CALL upb(nbyt,16,mbay(1,lun),ibit)
         mbyt(lun) = mbyt(lun) + nbyt
      elseif(msgunp(lun)==1) then
         mbyt(lun)=mbit
      endif
 
      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 up8(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 up8(ninc,linc,mbay(1,lun),jbit)
         ival = lref+ninc
         CALL usrtpl(lun,n,int(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 up8(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
      END