ufbmem.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>Any embedded DX BUFR tables contained within the file are also
C> read and processed into separate internal arrays for later use.
C>
C> @author J. Woollen
C> @date 1994-01-06
C>
C> @param[in] LUNIT    - integer: Fortran logical unit number for BUFR
C>                       file 
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] IUNIT   - integer: File status
C>                       - 0 = LUNIT was empty, so no messages were read
C>                       - Otherwise, the Fortran logical unit number to
C>                         use for later access to any of the messages
C>                         from the internal arrays
C>
C> <p>Logical unit number LUNIT must already be associated with an
C> actual filename on the local system, typically via a Fortran "OPEN"
C> statement.
C>
C> <p>When INEW = 0, the output value IUNIT will be set equal to the
C> input value LUNIT.  Otherwise, the output value IUNIT will be set to
C> the value of LUNIT that was input when this subroutine was previously
C> called with INEW = 0, and the system file connected to LUNIT will be
C> closed via an internal call to subroutine closbf() before exiting
C> this subroutine.  In either case, IUNIT can now be used to access
C> all BUFR messages that were read and stored by all previous calls
C> to this subroutine.  
C>
C> <b>Program history log:</b>
C> - 1994-01-06  J. Woollen -- Original author
C> - 1998-07-08  J. Woollen -- Replaced call to Cray library routine ABORT
C>                             with call to new internal routine bort()
C> - 1999-11-18  J. Woollen -- Increased MAXMEM from 4 Mb to 8 Mb
C> - 2000-09-19  J. Woollen -- Maximum message length increased
C>                             from 10,000 to 20,000 bytes
C> - 2001-08-15  D. Keyser  -- Increased MAXMEM from 8 Mb to 16 Mb
C> - 2003-11-04  S. Bender  -- Added remarks and routine interdependencies
C> - 2003-11-04  D. Keyser  -- Unified/portable for WRF; added history
C>                             documentation; outputs more complete
C>                             diagnostic info when routine terminates
C>                             abnormally; increased MAXMSG from 50000
C>                             to 200000
C> - 2004-08-09  J. Ator    -- Maximum message length increased 
C>                             from 20,000 to 50,000 bytes
C> - 2004-11-15  D. Keyser  -- Don't abort when there are either MAXMSG
C>                             or MAXMEM is exceeded; instead, just
C>                             store up to MAXMSG messages or MAXMEM
C>                             bytes and print a diagnostic
C> - 2005-11-29  J. Ator    -- Use rdmsgw() and nmwrd()
C> - 2009-03-23  J. Ator    -- Modified to handle embedded DX tables
C> - 2012-09-15  J. Woollen -- Modified for C/I/O/BUFR interface;
C>                             call status() to get LUN; replace Fortran
C>                             REWIND and BACKSPACE with C routines
C>                             cewind() and backbufr()
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 ufbmem(LUNIT,INEW,IRET,IUNIT)

      USE moda_mgwa
      USE moda_msgmem

      COMMON /quiet / iprt

      CHARACTER*128 bort_str,errstr

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

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

      CALL openbf(lunit,'IN',lunit)

      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     Copy any BUFR dictionary table messages from the beginning of
C     LUNIT into MODULE MSGMEM for possible later use.  Note that
C     such a table (if one exists) is already now in scope due to the
C     prior call to subroutine OPENBF, which in turn would have
C     automatically called subroutines READDX, RDBFDX and MAKESTAB
C     for this table.

      itemp = ndxts
      CALL status(lunit,lun,il,im)
      CALL cewind(lun)   
      CALL cpdxmm(lunit)

C     If a table was indeed present at the beginning of the file,
C     then set the flag to indicate that this table is now in scope.

      IF ((itemp+1).EQ.ndxts) ldxts = ndxts

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

      IF(idxmsg(mgwa).EQ.1) THEN

C   New "embedded" BUFR dictionary table messages have been found in
C   this file.  Copy them into MODULE MSGMEM for later use.

    CALL backbufr(lun) !BACKSPACE LUNIT
    CALL cpdxmm(lunit)
    goto 1
      ENDIF

      nmsg = nmsg+1
      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: UFBMEM - 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)' )
     . '>>>UFBMEM STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
      CALL errwrt(errstr)
      WRITE ( unit=errstr, fmt='(A,I8,A,I8,A)' )
     . '>>>UFBMEM 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: UFBMEM - 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)' )
     . '>>>UFBMEM STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
      CALL errwrt(errstr)
      WRITE ( unit=errstr, fmt='(A,I8,A,I8,A)' )
     . '>>>UFBMEM 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: UFBMEM - ERROR READING MESSAGE '//
     . 'NUMBER",I5," INTO MEMORY FROM UNIT",I3)') nmsg+1,lunit
      CALL bort(bort_str)
      END