ufbmex.f

Go to the documentation of this file.

C> @file
C> @brief Connect a new file to the BUFRLIB software, and read
C> the entire file contents into internal arrays.
C>
C> @author J. Woollen @date 2012-01-26
 
C> Connect a new file to the BUFRLIB software
C> for input operations, then read the entire file contents into
C> internal arrays so that any of the individual BUFR messages can
C> later be accessed from memory, instead of having to read them one
C> at a time sequentially from the file.
C>
C> This subroutine is similar to subroutine ufbmem(), except that
C> instead of a file status it returns an array of message types that
C> were read in.  Furthermore, this subroutine doesn't process any
C> embedded DX BUFR tables contained within the file; instead,
C> it provides an additional call argument LUNDX to allow
C> for specification of the necessary DX BUFR table information
C> associated with the messages in the file.
C>
C> Logical unit numbers LUNIT and LUNDX must already be associated
C> with actual filenames on the local system, typically via a Fortran
C> "OPEN" statement.
C>
C> @param[in] LUNIT - integer: Fortran logical unit number for BUFR file.
C> @param[in] LUNDX - integer: Fortran logical unit number containing DX
C> BUFR table information associated with BUFR messages in LUNIT.
C> @param[in] INEW - integer: Processing option
C> - 0 = Initialize the internal arrays, then read all BUFR messages
C> from LUNIT into internal arrays
C> - Otherwise, read all BUFR messages from LUNIT and append them to the
C> existing messages within the internal arrays
C> @param[out] IRET - integer: Number of BUFR messages that were read
C> from LUNIT and stored into internal arrays.
C> @param[out] MESG - integer(*): Types of BUFR messages that were read
C> from LUNIT and stored into internal arrays.
C>
C> @author J. Woollen @date 2012-01-26
      RECURSIVE SUBROUTINE ufbmex(LUNIT,LUNDX,INEW,IRET,MESG)
 
      USE modv_im8b
      USE modv_maxmem
      USE modv_maxmsg
 
      USE moda_mgwa
      USE moda_msgmem
 
      COMMON /quiet / iprt
 
      CHARACTER*128 bort_str,errstr
 
      INTEGER mesg(*), iret(*), lunit(*), lundx(*), inew(*)
      INTEGER my_lunit(1), my_lundx(1), my_inew(1)
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL x84(lundx,my_lundx,1)
         CALL x84(inew,my_inew,1)
         IF (my_inew(1).EQ.0) THEN
            nmesg = 0
         ELSE
            nmesg = msgp(0)
            CALL x84(mesg,mesg,nmesg)
         ENDIF
         CALL ufbmex(my_lunit,my_lundx,my_inew,iret,mesg)
         CALL x48(mesg,mesg,nmesg+iret(1))
         CALL x48(iret,iret,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
C  TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE
C  ----------------------------------------------------------
 
      CALL openbf(lunit,'IN',lundx)
 
      IF(inew(1).EQ.0) THEN
         msgp(0) = 0
         munit = 0
         mlast = 0
         ndxts = 0
         ldxts = 0
         ndxm = 0
         ldxm = 0
      ENDIF
 
      nmsg = msgp(0)
      iret(1) = 0
      iflg = 0
      itim = 0
 
C  SET SOME FLAGS SO THAT SUBSEQUENT CALLS TO THE MESSAGE READING
C  ROUTINES WILL KNOW THERE IS A BUFR TABLE IN SCOPE.
 
      ndxts = 1
      ldxts = 1
      ipmsgs(1) = 1
 
C  TRANSFER MESSAGES FROM FILE TO MEMORY - SET MESSAGE POINTERS
C  ------------------------------------------------------------
 
1     CALL rdmsgw(lunit,mgwa,ier)
      IF(ier.EQ.-1) GOTO 100
      IF(ier.EQ.-2) GOTO 900
 
      nmsg = nmsg+1
      mesg(nmsg) = iupbs01(mgwa,'MTYP')
      IF(nmsg      .GT.maxmsg) iflg = 1
      lmem = nmwrd(mgwa)
      IF(lmem+mlast.GT.maxmem) iflg = 2
 
      IF(iflg.EQ.0) THEN
         iret(1) = iret(1)+1
         DO i=1,lmem
            msgs(mlast+i) = mgwa(i)
         ENDDO
         msgp(0)    = nmsg
         msgp(nmsg) = mlast+1
      ELSE
         IF(itim.EQ.0) THEN
            mlast0 = mlast
            itim=1
         ENDIF
      ENDIF
      mlast = mlast+lmem
      GOTO 1
 
C  EXITS
C  -----
 
100   IF(iflg.EQ.1) THEN
 
C  EMERGENCY ROOM TREATMENT FOR MAXMSG ARRAY OVERFLOW
C  --------------------------------------------------
 
      IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      WRITE ( unit=errstr, fmt='(A,A,I8,A)' )
     . 'BUFRLIB: UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ',
     . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmsg,
     . ') - INCOMPLETE READ'
      CALL errwrt(errstr)
      WRITE ( unit=errstr, fmt='(A,I8,A,I8,A)' )
     . '>>>UFBMEX STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
      CALL errwrt(errstr)
      WRITE ( unit=errstr, fmt='(A,I8,A,I8,A)' )
     . '>>>UFBMEX STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
      CALL errwrt(errstr)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
      ENDIF
      mlast=mlast0
      ENDIF
 
      IF(iflg.EQ.2) THEN
 
C  EMERGENCY ROOM TREATMENT FOR MAXMEM ARRAY OVERFLOW
C  --------------------------------------------------
 
      IF(iprt.GE.0) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      WRITE ( unit=errstr, fmt='(A,A,I8,A)' )
     . 'BUFRLIB: UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ',
     . 'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmem,
     . ') - INCOMPLETE READ'
      CALL errwrt(errstr)
      WRITE ( unit=errstr, fmt='(A,I8,A,I8,A)' )
     . '>>>UFBMEX STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
      CALL errwrt(errstr)
      WRITE ( unit=errstr, fmt='(A,I8,A,I8,A)' )
     . '>>>UFBMEX STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
      CALL errwrt(errstr)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
      ENDIF
      mlast=mlast0
      ENDIF
 
      IF(iret(1).EQ.0) THEN
         CALL closbf(lunit)
      ELSE
         IF(munit.NE.0) CALL closbf(lunit)
         IF(munit.EQ.0) munit = lunit(1)
      ENDIF
 
C  EXITS
C  -----
 
      RETURN
900   WRITE(bort_str,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE '//
     . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') nmsg+1,lunit(1)
      CALL bort(bort_str)
      END