ufbmex.f

Go to the documentation of this file.

C> @file
C> @brief Connect a new system file to the BUFRLIB software, and read
C> the entire file contents into internal arrays.

C> This subroutine connects a new system file to the BUFRLIB software
C> for input operations, then reads 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 system file.
C>
C> <p>This subroutine is similar to subroutine ufbmem(), except that
C> after reading in all of the messages, it then sorts them according
C> to their message types and returns a corresponding list of these
C> types.  Furthermore, it does not process any embedded DX BUFR
C> tables contained within the system file, since these tables are no
C> longer relevant once the messages have been sorted and re-ordered
C> from their original positions in the file.  Instead, this
C> subroutine 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> @author J. Woollen
C> @date 2012-01-26
C>
C> @param[in] LUNIT   -- integer: Fortran logical unit number for BUFR
C>                       file
C> @param[in] LUNDX   -- integer: Fortran logical unit number
C>                       containing DX BUFR table information
C>                       associated with BUFR messages in LUNIT
C> @param[in] INEW    -- integer: Processing option
C>                       - 0 = Initialize the internal arrays, then
C>                             read all BUFR messages from LUNIT into
C>                             internal arrays
C>                       - Otherwise, read all BUFR messages from LUNIT
C>                         and append them to the existing messages
C>                         within the internal arrays
C> @param[out] IRET   -- integer: Number of BUFR messages that were
C>                       read from LUNIT and stored into internal arrays
C> @param[out] MESG   -- integer(*): Types of BUFR messages that were
C>                       read from LUNIT and stored into internal arrays
C>
C> <p>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> <b>Program history log:</b>
C> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 2012-01-26 | J. Woollen | Original author |
C> | 2014-12-10 | J. Ator    | Use modules instead of COMMON blocks |
C> | 2015-09-24 | D. Stokes  | Fix missing declaration of COMMON /QUIET/ |
C>
      SUBROUTINE ufbmex(LUNIT,LUNDX,INEW,IRET,MESG) 

      USE moda_mgwa
      USE moda_msgmem

      COMMON /quiet / iprt

      CHARACTER*128 bort_str,errstr

      INTEGER       mesg(*)

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

C  TRY TO OPEN BUFR FILE AND SET TO INITIALIZE OR CONCATENATE
C  ----------------------------------------------------------

      CALL openbf(lunit,'IN',lundx)

      IF(inew.EQ.0) THEN
         msgp(0) = 0
         munit = 0
         mlast = 0
         ndxts = 0
         ldxts = 0
         ndxm = 0
         ldxm = 0
      ENDIF

      nmsg = msgp(0)
      iret = 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 = iret+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.EQ.0) THEN
         CALL closbf(lunit)
      ELSE
         IF(munit.NE.0) CALL closbf(lunit)
         IF(munit.EQ.0) munit = lunit
      ENDIF
      iunit = munit

C  EXITS
C  -----

      RETURN
900   WRITE(bort_str,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE '//
     . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') nmsg+1,lunit
      CALL bort(bort_str)
      END