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> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 1994-01-06 | J. Woollen | Original author |
C> | 1998-07-08 | J. Woollen | Replaced call to Cray library routine ABORT 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 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 documentation; outputs more complete diagnostic info when routine terminates abnormally; increased MAXMSG from 50000 to 200000 |
C> | 2004-08-09 | J. Ator    | Maximum message length increased from 20,000 to 50,000 bytes |
C> | 2004-11-15 | D. Keyser  | Don't abort when there are either MAXMSG or MAXMEM is exceeded; instead, just store up to MAXMSG messages or MAXMEM 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; call status() to get LUN; replace Fortran REWIND and BACKSPACE with C routines 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