ufbmem.f

Go to the documentation of this file.

C> @file
C> @brief Connect a new file to the NCEPLIBS-bufr software,
C> and read the entire file contents into internal arrays.
C>
C> @author J. Woollen @date 1994-01-06
 
C> This subroutine connects a new file to the NCEPLIBS-bufr 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 file.
C>
C> Any embedded DX BUFR tables contained within the file are also
C> read and processed into separate internal arrays for later use.
C>
C> 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> 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> @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> @author J. Woollen @date 1994-01-06
      RECURSIVE SUBROUTINE ufbmem(LUNIT,INEW,IRET,IUNIT)
 
      use bufrlib
 
      USE modv_maxmem
      USE modv_maxmsg
      USE modv_im8b
 
      USE moda_mgwa
      USE moda_msgmem
 
      COMMON /quiet / iprt
 
      CHARACTER*128 bort_str,errstr
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL x84(inew,my_inew,1)
         CALL ufbmem(my_lunit,my_inew,iret,iunit)
         CALL x48(iret,iret,1)
         CALL x48(iunit,iunit,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
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_c(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_c(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