rdmemm.f

Go to the documentation of this file.

C> @file
C> @brief Read a specified BUFR message from internal arrays.
C>
C> @author J. Woollen @date 1994-01-06
 
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> BUFR messages should already be stored within internal
C> arrays in memory via one or more previous calls to
C> subroutine ufbmem().
C>
C> This subroutine is similar to subroutine readmm(), except that
C> readmm() also increments the value of IMSG prior to returning to
C> the calling program, which in turn allows it to be easily called
C> within an iterative program loop.
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> @author J. Woollen @date 1994-01-06
      RECURSIVE SUBROUTINE rdmemm(IMSG,SUBSET,JDATE,IRET)
 
      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_mgwa
      USE moda_msgmem
      USE modv_im8b
 
      COMMON /quiet / iprt
 
      CHARACTER*128 bort_str,errstr
      CHARACTER*8   subset
 
      LOGICAL known
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(imsg,my_imsg,1)
         CALL rdmemm(my_imsg,subset,jdate,iret)
         CALL x48(jdate,jdate,1)
         CALL x48(iret,iret,1)
 
         im8b=.true.
         RETURN
      ENDIF
 
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