ufbget.f

Go to the documentation of this file.

C> @file
C> @brief Read one or more data values from a data subset.
C>
C> @author Woollen @date 1994-01-06
 
C> Read one or more data values from a data subset.
C>
C> This subroutine unpacks and returns the values for one-dimensional
C> descriptors in the input string without advancing the subset pointer.
C>
C> @param[in] LUNIT - integer: fortran logical unit number for BUFR file.
C> @param[out] TAB - real*8(*): data values.
C> @param[in] I1 - integer: size of TAB as allocated within the calling program.
C> @param[out] IRET - integer: return code:
C> - 0 normal return.
C> - -1 there are no more subsets in the BUFR message.
C> @param[in] STR - character*(*): string of blank-separated Table B
C> mnemonics in one-to-one correspondence with the number of data values
C> that will be read from the data subset into TAB.
C>
C> @author Woollen @date 1994-01-06
      RECURSIVE SUBROUTINE ufbget(LUNIT,TAB,I1,IRET,STR)
 
      USE modv_bmiss
      USE modv_im8b
 
      USE moda_usrint
      USE moda_usrbit
      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_tables
 
      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
 
      CHARACTER*(*) str
      CHARACTER*8   cval
      equivalence(cval,rval)
      INTEGER*8     ival
      real*8        rval,tab(i1),ups
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL x84(i1,my_i1,1)
         CALL ufbget(my_lunit,tab,my_i1,iret,str)
         CALL x48(iret,iret,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
      iret = 0
 
      DO i=1,i1
      tab(i) = bmiss
      ENDDO
 
C  MAKE SURE A FILE/MESSAGE IS OPEN FOR INPUT
C  ------------------------------------------
 
      CALL status(lunit,lun,il,im)
      IF(il.EQ.0) GOTO 900
      IF(il.GT.0) GOTO 901
      IF(im.EQ.0) GOTO 902
 
C  SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE
C  ---------------------------------------------
 
      IF(nsub(lun).EQ.msub(lun)) THEN
         iret = -1
         GOTO 100
      ENDIF
 
C  PARSE THE STRING
C  ----------------
 
      CALL string(str,lun,i1,0)
 
C  EXPAND THE TEMPLATE FOR THIS SUBSET AS LITTLE AS POSSIBLE
C  ---------------------------------------------------------
 
      n = 1
      nbit(n) = 0
      mbit(n) = mbyt(lun)*8 + 16
      CALL usrtpl(lun,n,n)
 
10    DO n=n+1,nval(lun)
      node = inv(n,lun)
      nbit(n) = ibt(node)
      mbit(n) = mbit(n-1)+nbit(n-1)
      IF(node.EQ.nods(nnod)) THEN
         nval(lun) = n
         GOTO 20
      ELSEIF(itp(node).EQ.1) THEN
         CALL upb8(ival,nbit(n),mbit(n),mbay(1,lun))
         nbmp=int(ival)
         CALL usrtpl(lun,n,nbmp)
         GOTO 10
      ENDIF
      ENDDO
20    CONTINUE
 
C  UNPACK ONLY THE NODES FOUND IN THE STRING
C  -----------------------------------------
 
      DO i=1,nnod
      node = nods(i)
      invn = invwin(node,lun,1,nval(lun))
      IF(invn.GT.0) THEN
         CALL upb8(ival,nbit(invn),mbit(invn),mbay(1,lun))
         IF(itp(node).EQ.1) THEN
            tab(i) = ival
         ELSEIF(itp(node).EQ.2) THEN
            IF(ival.LT.2_8**(ibt(node))-1) tab(i) = ups(ival,node)
         ELSEIF(itp(node).EQ.3) THEN
            cval = ' '
            kbit = mbit(invn)
            CALL upc(cval,nbit(invn)/8,mbay(1,lun),kbit,.true.)
            tab(i) = rval
         ENDIF
      ELSE
         tab(i) = bmiss
      ENDIF
      ENDDO
 
C  EXITS
C  -----
 
100   RETURN
900   CALL bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS CLOSED, IT MUST'//
     . ' BE OPEN FOR INPUT')
901   CALL bort('BUFRLIB: UFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT'//
     . ', IT MUST BE OPEN FOR INPUT')
902   CALL bort('BUFRLIB: UFBGET - A MESSAGE MUST BE OPEN IN INPUT '//
     . 'BUFR FILE, NONE ARE')
      END