readerme.f

Go to the documentation of this file.

C> @file
C> @brief Read a BUFR message from a memory array.

C> This subroutine is similar to subroutine readmg(), except that it
C> reads a BUFR message from an array already in memory, whereas
C> readmg() reads a BUFR message from a file on the local system.
C>
C> @authors J. Woollen
C> @authors J. Ator
C> @date 1995-06-28
C>
C> @param[in] MESG     - integer(*): BUFR message
C> @param[in] LUNIT    - integer: Fortran logical unit number for
C>                       BUFR file
C> @param[out] SUBSET   - character*8: Table A mnemonic for type of BUFR
C>                        message that was read
C>                        (see [DX BUFR Tables](@ref dfbftab)
C>                        for further information about Table A mnemonics)
C> @param[out] JDATE    - integer: Date-time stored within Section 1 of
C>                        BUFR message that was read, in format of either
C>                        YYMMDDHH or YYYYMMDDHH, depending on the most
C>                        recent call to subroutine datelen()
C> @param[out] IRET     - integer: return code
C>                           - 0 = MESG was successfully read
C>                           - 11 = MESG contained a DX BUFR table message
C>                           - -1 = MESG contained an unrecognized
C>                                  Table A message type
C>
C> <p>This subroutine looks and behaves a lot like subroutine readmg() 
C> except that here we have one additional input argument MESG which
C> contains the BUFR message to be read by the BUFRLIB software.
C> As such, this subroutine can be used in any context in which readmg()
C> might otherwise be used, and from that point on, the application
C> program can proceed with a call to one of the
C> [subset-reading subroutines](@ref hierarchy) (and then,
C> subsequently, to any of the
C> [values-reading subroutines](@ref hierarchy)), just
C> like if readmg() had been called instead.
C>
C> <p>When using this subroutine, it's still necessary for the
C> application program to have previously called subroutine openbf() in
C> order to associate a DX BUFR tables file with the messages that are
C> being input via MESG, and it's still also necessary to pass in the
C> relevant LUNIT value as a call argument, even though in this case
C> the subroutine will not actually try to read from the associated
C> Fortran logical unit.
C>
C> <p>If MESG contains a DX BUFR table message, the subroutine will
C> store the contents internally and use them to process any
C> future BUFR messages associated with LUNIT.  In this case, the
C> subroutine will return with IRET = 11, and any number of
C> DX BUFR table messages passed in via consecutive calls to this
C> subroutine will accumulate internally and be treated as a single DX
C> BUFR table, up until a call is made where MESG no longer contains a
C> DX BUFR table message.
C>
C> <b>Program history log:</b>
C> - 1995-06-28  J. Woollen -- Original author
C> - 1997-07-29  J. Woollen -- Modified to process GOES soundings
C>                             from NESDIS
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; improved machine portability
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 the
C>                           maximum number of possible descriptors in
C>                           a subset from 1000 to 3000
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> - 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
C> - 2004-08-18  J. Ator    -- Modified 'BUFR' string test for portability
C>                           to EBCDIC machines; maximum message length
C>                           increased from 20,000 to 50,000 bytes
C> - 2005-11-29  J. Ator    -- Use ichkstr()
C> - 2009-03-23  D. Keyser  -- Call bort() in case of MBAY overflow
C> - 2009-03-23  J. Ator    -- Add logic to allow Section 3 decoding;
C>                           add logic to process dictionary messages
C> - 2012-06-07  J. Ator    -- Don't respond to DX table messages if
C>                           Section 3 decoding is being used
C> - 2014-12-10  J. Ator    -- Use modules instead of COMMON blocks
C>
      SUBROUTINE readerme(MESG,LUNIT,SUBSET,JDATE,IRET)

      USE moda_sc3bfr
      USE moda_idrdm
      USE moda_bitbuf

      COMMON /hrdwrd/ nbytw,nbitw,iord(8)
      COMMON /quiet/  iprt

      CHARACTER*128 bort_str,errstr
      CHARACTER*8 subset,sec0
      CHARACTER*1 cec0(8)

      dimension   mesg(*),iec0(2)

      LOGICAL endtbl

      equivalence(sec0,iec0,cec0)

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

      iret = 0

C  CHECK THE FILE STATUS
C  ---------------------

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

C  COPY THE INPUT MESSAGE INTO THE INTERNAL MESSAGE BUFFER
C  -------------------------------------------------------

      iec0(1) = mesg(1)
      iec0(2) = mesg(2)
      lnmsg = lmsg(sec0)
      IF(lnmsg*nbytw.GT.mxmsgl) goto 902
      DO i=1,lnmsg
        mbay(i,lun) = mesg(i)
      ENDDO

C     Confirm that the first 4 bytes of SEC0 contain 'BUFR' encoded in
C     CCITT IA5 (i.e. ASCII).

      IF(ichkstr('BUFR',cec0,4).NE.0) goto 903

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

      IF(isc3(lun).NE.0) CALL reads3(lun)

      CALL cktaba(lun,subset,jdate,iret)

      IF(isc3(lun).NE.0) RETURN

C  CHECK FOR A DX DICTIONARY MESSAGE
C  ---------------------------------

C     A new DX dictionary table can be passed in as a consecutive set of
C     DX dictionary messages.  Each message should be passed in one at a
C     time, via input argument MESG during consecutive calls to this
C     subroutine, and will be processed as a single dictionary table up
C     until the next message is passed in which either contains no data
C     subsets or else is a non-DX dictionary message.

      endtbl = .false.

      IF(idxmsg(mbay(1,lun)).EQ.1) THEN

C   This is a DX dictionary message that was generated by the
C   BUFRLIB archive library software.

    IF(iupbs3(mbay(1,lun),'NSUB').EQ.0) THEN

C     But it doesn't contain any actual dictionary information, so
C     assume we've reached the end of the dictionary table.

      IF(idrdm(lun).GT.0) THEN
        endtbl = .true.
          ENDIF
    ELSE
      IF(idrdm(lun).EQ.0) THEN

C       This is the first DX dictionary message that is part of a
C       new dictionary table.

        CALL dxinit(lun,0)
      ENDIF
      idrdm(lun) = idrdm(lun) + 1
      CALL stbfdx(lun,mbay(1,lun))
    ENDIF
      ELSE IF(idrdm(lun).GT.0) THEN

C   This is the first non-DX dictionary message received following a
C       string of DX dictionary messages, so assume we've reached the
C   end of the dictionary table.

    endtbl = .true.
      ENDIF

      IF(endtbl) THEN
    IF ( iprt .GE. 2 ) THEN
    CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++')
    WRITE ( unit=errstr, fmt='(A,I3,A)' )
     .    'BUFRLIB: READERME - STORED NEW DX TABLE CONSISTING OF (',
     .    idrdm(lun), ') MESSAGES;'
    CALL errwrt(errstr)
    errstr = 'WILL APPLY THIS TABLE TO ALL SUBSEQUENT DATA '//
     .    'MESSAGES UNTIL NEXT DX TABLE IS PASSED IN'
    CALL errwrt(errstr)
    CALL errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++')
        CALL errwrt(' ')
    ENDIF
    idrdm(lun) = 0
    CALL makestab
      ENDIF

C  EXITS
C  -----

      RETURN
900   CALL bort('BUFRLIB: READERME - INPUT BUFR FILE IS CLOSED, IT '//
     . 'MUST BE OPEN FOR INPUT')
901   CALL bort('BUFRLIB: READERME - INPUT BUFR FILE IS OPEN FOR '//
     . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
902   WRITE(bort_str,'("BUFRLIB: READERME - INPUT BUFR MESSAGE LENGTH",
     . 1X,I6," BYTES) IS LARGER THAN LIMIT OF ",I6," BYTES")')
     . lnmsg*nbytw,mxmsgl
      CALL bort(bort_str)
903   CALL bort('BUFRLIB: READERME - FIRST 4 BYTES READ FROM RECORD'//
     . ' NOT "BUFR", DOES NOT CONTAIN BUFR DATA')
      END