ufbtam.f

Go to the documentation of this file.

C> @file
C> @brief Read one or more data values from every data subset in
C> internal arrays
C>
C> @author J. Woollen @date 1994-01-06
 
C> This subroutine reads through every data subset in internal arrays
C> and returns one or more specified data values from each subset.
C>
C> This provides a useful way to scan the ranges of one or more
C> specified data values across all of the data subsets in the
C> internal arrays.  It is similar to subroutine ufbtab(), except
C> that ufbtab() works on data subsets in a BUFR file.
C>
C> 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 internal arrays.  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 internal arrays.
C>
C> The internal arrays must have already been populated via a previous
C> call to subroutine ufbmem().
C>
C> There are a few additional special mnemonics that can be
C> included within STR when calling this subroutine, and which in turn
C> will result in special information being returned within the
C> corresponding location in TAB:
C> - IREC - returns the number of the BUFR message within the
C>   internal arrays (counting from the beginning of the
C>   internal arrays) in which the current data subset resides.
C> - ISUB - returns the number of the current data subset within
C>   the BUFR message pointed to by IREC, counting from
C>   the beginning of the message.
C> - ITBL - returns the number of the DX BUFR table that is
C>   in scope for the current data subset.
C>
C> This subroutine will not work on compressed data subsets.
C>
C> @param[out] TAB    -- real*8(*,*): Data values.
C> @param[in] I1 -- integer: First dimension of TAB as allocated
C>                  within the calling program.
C> @param[in] I2 -- integer: Second dimension of TAB as allocated
C>                  within the calling program.
C> @param[out] IRET -- integer: Number of data subsets in internal arrays.
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> @author J. Woollen @date 1994-01-06
      RECURSIVE SUBROUTINE ufbtam(TAB,I1,I2,IRET,STR)
 
      USE modv_bmiss
      USE modv_im8b
 
      USE moda_usrint
      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_msgmem
      USE moda_tables
 
      COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),vals(10),kons(10)
      COMMON /quiet / iprt
 
      CHARACTER*(*) str
      CHARACTER*128 bort_str,errstr
      CHARACTER*10  tgs(100)
      CHARACTER*8   subset,cval
      equivalence(cval,rval)
      integer*8     mps,ival
      real*8        tab(i1,i2),rval,ups
 
      DATA maxtg /100/
 
C-----------------------------------------------------------------------
      mps(node) = 2_8**(ibt(node))-1
C-----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(i1,my_i1,1)
         CALL x84(i2,my_i2,1)
         CALL ufbtam(tab,my_i1,my_i2,iret,str)
         CALL x48(iret,iret,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
      iret = 0
 
      IF(msgp(0).EQ.0) GOTO 100
 
      DO j=1,i2
      DO i=1,i1
      tab(i,j) = bmiss
      ENDDO
      ENDDO
 
C  CHECK FOR SPECIAL TAGS IN STRING
C  --------------------------------
 
      CALL parstr(str,tgs,maxtg,ntg,' ',.true.)
      irec = 0
      isub = 0
      itbl = 0
      DO i=1,ntg
      IF(tgs(i).EQ.'IREC') irec = i
      IF(tgs(i).EQ.'ISUB') isub = i
      IF(tgs(i).EQ.'ITBL') itbl = i
      ENDDO
 
C  READ A MESSAGE AND PARSE A STRING
C  ---------------------------------
 
      CALL status(munit,lun,il,im)
 
      DO imsg=1,msgp(0)
      CALL rdmemm(imsg,subset,jdate,mret)
      IF(mret.LT.0) GOTO 900
 
      CALL string(str,lun,i1,0)
      IF(irec.GT.0) nods(irec) = 0
      IF(isub.GT.0) nods(isub) = 0
      IF(itbl.GT.0) nods(itbl) = 0
 
C  PROCESS ALL THE SUBSETS IN THE MEMORY MESSAGE
C  ---------------------------------------------
 
      DO WHILE (nsub(lun).LT.msub(lun))
         IF(iret+1.GT.i2) GOTO 99
         iret = iret+1
 
         DO i=1,nnod
         nods(i) = abs(nods(i))
         ENDDO
 
         CALL usrtpl(lun,1,1)
         mbit = mbyt(lun)*8+16
         nbit = 0
         n = 1
 
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=int(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  -------------------------------------------
 
         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)
         IF(itbl.GT.0) tab(itbl,iret) = ldxts
      ENDDO
 
      ENDDO
 
      GOTO 200
 
C  EMERGENCY ROOM TREATMENT FOR ARRAY OVERFLOW
C  -------------------------------------------
 
99    CALL rdmemm(0,subset,jdate,mret)
      nrep = 0
      DO imsg=1,msgp(0)
      CALL rdmemm(imsg,subset,jdate,mret)
      IF(mret.LT.0) GOTO 900
      nrep = nrep+nmsub(munit)
      ENDDO
      IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      WRITE ( unit=errstr, fmt='(A,A,I8,A,A)' )
     . 'BUFRLIB: UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY ',
     . .GT.'IS  LIMIT OF ', i2, ' IN THE 3RD ARG. (INPUT) - ',
     . 'INCOMPLETE READ'
      CALL errwrt(errstr)
      WRITE ( unit=errstr, fmt='(A,I8,A,I8,A)' )
     . '>>>UFBTAM STORED ', iret, ' REPORTS OUT OF ', nrep, '<<<'
      CALL errwrt(errstr)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
      ENDIF
 
C  RESET THE MEMORY FILE
C  ---------------------
 
200   CALL rdmemm(0,subset,jdate,mret)
 
C  EXITS
C  -----
 
100   RETURN
900   WRITE(bort_str,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING '//
     . 'MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') imsg
      CALL bort(bort_str)
      END