readerme.f

Go to the documentation of this file.

C> @file
C> @brief Read a BUFR message from a memory array.
C>
C> @authors J. Woollen J. Ator @date 1995-06-28
 
C> Read a BUFR message from a memory array.      
C>
C> This subroutine is similar to subroutine readmg(), except that it
C> reads a BUFR message from an array passed as input, whereas
C> readmg() reads a BUFR message from a file on the local system.
C>
C> 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)).
C>
C> When using this subroutine, it's necessary for the
C> application program to have previously called subroutine openbf() in
C> order to associate a DX BUFR tables file with the message that is
C> being input via MESG; it's 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> 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> @param[in] MESG - integer(*): BUFR message.
C> @param[in] LUNIT - integer: Fortran logical unit number for BUFR file.
C> @param[out] SUBSET - character*8: Table A mnemonic for type of BUFR
C> message that was read (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 YYMMDDHH or YYYYMMDDHH,
C> depending on the most recent call to 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 Table A message type.
C>
C> @authors J. Woollen J. Ator @date 1995-06-28
 
      RECURSIVE SUBROUTINE readerme(MESG,LUNIT,SUBSET,JDATE,IRET)
 
      USE modv_mxmsgl
      USE modv_im8b
 
      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
 
      dimension   mesg(*),iec0(2)
 
      LOGICAL endtbl
 
      equivalence(sec0,iec0)
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL readerme(mesg,my_lunit,subset,jdate,iret)
         CALL x48(jdate,jdate,1)
         CALL x48(iret,iret,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
      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'.
 
      IF(sec0(1:4).NE.'BUFR') 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