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> | 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(); modified to make Y2K compliant |
C> | 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32; increased MAXMEM from 4 Mb to 8 Mb |
C> | 2000-09-19 | J. Woollen | Removed logic that had been replicated in this and other read routines and consolidated it into a new routine cktaba(); 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 |
C> | 2004-08-09 | J. Ator    | Maximum message length increased 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 (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