rdmemm.f

Go to the documentation of this file.

C> @file
C> @brief Read a specified BUFR message from internal arrays.

C> This subroutine reads a specified BUFR message from internal
C> arrays in memory, so that it is now in scope for processing
C> via a subsequent call to subroutine rdmems().
C>
C> <p>BUFR messages should already be stored within internal
C> arrays in memory via one or more previous calls to
C> subroutine ufbmem().
C>
C> @author J. Woollen
C> @date 1994-01-06
C>
C> @param[in] IMSG    - integer: Number of BUFR message to be
C>                      read into scope for further processing,
C>                      counting from the beginning of the
C>                      internal arrays in memory
C> @param[out] SUBSET - character*8: Table A mnemonic for type of BUFR
C>                      message that was read into scope
C>                      (see [DX BUFR Tables](@ref dfbftab) for
C>                      further information about Table A mnemonics)
C> @param[out] JDATE  - integer: Date-time stored within Section 1 of
C>                      BUFR message that was read into scope,
C>                      in format of either YYMMDDHH or YYYYMMDDHH,
C>                      depending on the most
C>                      recent call to subroutine datelen()
C> @param[out] IRET   - integer: return code
C>                          - 0 = requested message was
C>                                successfully read into scope
C>                          - -1 = requested message number could not
C>                                 be found in internal arrays
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
C>                           "ABORT" with call to new internal BUFRLIB
C>                           routine "BORT"; modified to make Y2K
C>                           compliant
C> - 1999-11-18  J. Woollen -- The number of BUFR files which can be
C>                           opened at one time increased from 10 to 32
C>                           (necessary in order to process multiple
C>                           BUFR files under the MPI); increased MAXMEM
C>                           from 4 Mb to 8 Mb
C> - 2000-09-19  J. Woollen -- Removed message decoding logic that had
C>                           been replicated in this and other read
C>                           routines and consolidated it into a new
C>                           routine cktaba(); maximum message
C>                           length increased from 10,000 to 20,000
C>                           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
C> - 2004-08-09  J. Ator    -- Maximum message length increased
C>                             from 20,000 to 50,000 bytes
C> - 2004-11-15  D. Keyser  -- Increased MAXMEM from 16 Mb to 50 Mb
C> - 2009-03-23  J. Ator    -- Modified to handle embedded BUFR table
C>                           (dictionary) messages; use errwrt()
C> - 2014-12-10  J. Ator    -- Use modules instead of COMMON blocks
C>
      SUBROUTINE rdmemm(IMSG,SUBSET,JDATE,IRET)

      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_mgwa
      USE moda_msgmem

      COMMON /quiet / iprt

      CHARACTER*128 bort_str,errstr
      CHARACTER*8   subset

      LOGICAL known

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

C  CHECK THE MESSAGE REQUEST AND FILE STATUS
C  -----------------------------------------

      CALL status(munit,lun,il,im)
      CALL wtstat(munit,lun,il, 1)
      IF(il.EQ.0) goto 900
      IF(il.GT.0) goto 901
      iret = 0

      IF(imsg.EQ.0 .OR.imsg.GT.msgp(0)) THEN
         CALL wtstat(munit,lun,il,0)
         IF(iprt.GE.1) THEN
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
            IF(imsg.EQ.0)  THEN
               errstr = 'BUFRLIB: RDMEMM - REQUESTED MEMORY MESSAGE '//
     .          'NUMBER {FIRST (INPUT) ARGUMENT} IS 0, RETURN WITH '//
     .          'IRET = -1'
            ELSE
               WRITE ( unit=errstr, fmt='(A,I6,A,I6,A)' )
     .          'BUFRLIB: RDMEMM - REQ. MEMORY MESSAGE #', imsg,
     .          ' {= 1ST (INPUT) ARG.} > # OF MESSAGES IN MEMORY (',
     .          msgp(0), '), RETURN WITH IRET = -1'
            ENDIF
            CALL errwrt(errstr)
      CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      CALL errwrt(' ')
         ENDIF
         iret = -1
         goto 100
      ENDIF

C  ENSURE THAT THE PROPER DICTIONARY TABLE IS IN SCOPE
C  ---------------------------------------------------

C     Determine which table applies to this message.

      known = .false.
      jj = ndxts
      DO WHILE ((.NOT.known).AND.(jj.GE.1))
     IF (ipmsgs(jj).LE.imsg) THEN
        known = .true.
     ELSE
        jj = jj - 1
     ENDIF
      ENDDO
      IF (.NOT.known) goto 902

C     Is this table the one that is currently in scope?

      IF (jj.NE.ldxts) THEN

C    No, so reset the software to use the proper table.

     IF(iprt.GE.2) THEN
            CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
            WRITE ( unit=errstr, fmt='(A,I3,A,I3,A,I6)' )
     .        'BUFRLIB: RDMEMM - RESETTING TO USE DX TABLE #', jj,
     .        ' INSTEAD OF DX TABLE #', ldxts,
     .        ' FOR REQUESTED MESSAGE #', imsg
            CALL errwrt(errstr)
            CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
            CALL errwrt(' ')
     ENDIF
     CALL dxinit(lun,0)

C    Store each of the DX dictionary messages which constitute
C    this table.

     DO ii = ifdxts(jj), (ifdxts(jj)+icdxts(jj)-1)
        IF (ii.EQ.ndxm) THEN
           nwrd = ldxm - ipdxm(ii) + 1
        ELSE
           nwrd = ipdxm(ii+1) - ipdxm(ii)
        ENDIF
        DO kk = 1, nwrd
           mgwa(kk) = mdx(ipdxm(ii)+kk-1)
        ENDDO
        CALL stbfdx(lun,mgwa)
     ENDDO

C    Rebuild the internal jump/link table.

     CALL makestab
     ldxts = jj
      ENDIF

C  READ MEMORY MESSAGE NUMBER IMSG INTO A MESSAGE BUFFER
C  -----------------------------------------------------

      iptr = msgp(imsg)
      IF(imsg.LT.msgp(0)) lptr = msgp(imsg+1)-iptr
      IF(imsg.EQ.msgp(0)) lptr = mlast-iptr+1
      iptr = iptr-1

      DO i=1,lptr
         mbay(i,lun) = msgs(iptr+i)
      ENDDO

C  PARSE THE MESSAGE SECTION CONTENTS
C  ----------------------------------

      CALL cktaba(lun,subset,jdate,jret)
      nmsg(lun) = imsg

C  EXITS
C  -----

100   RETURN
900   CALL bort('BUFRLIB: RDMEMM - INPUT BUFR FILE IS CLOSED, IT '//
     . 'MUST BE OPEN FOR INPUT')
901   CALL bort('BUFRLIB: RDMEMM - INPUT BUFR FILE IS OPEN FOR '//
     . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
902   WRITE(bort_str,'("BUFRLIB: RDMEMM - UNKNOWN DX TABLE FOR '//
     . 'REQUESTED MESSAGE #",I5)') imsg
      CALL bort(bort_str)
      END