memmsgs.F90

Go to the documentation of this file.

 
 
recursive subroutine ufbmem(lunit,inew,iret,iunit)
 
  use bufrlib
 
  use modv_vars, only: im8b, maxmem, maxmsg, iprt
 
  use moda_mgwa
  use moda_msgmem
 
  implicit none
 
  integer, intent(in) :: lunit, inew
  integer, intent(out) :: iret, iunit
  integer my_lunit, my_inew, iflg, itim, lun, il, im, itemp, ier, nmsg, lmem, i, mlast0, idxmsg, nmwrd, bort_target_set
 
  character*128 bort_str, errstr
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call x84(inew,my_inew,1)
    call ufbmem(my_lunit,my_inew,iret,iunit)
    call x48(iret,iret,1)
    call x48(iunit,iunit,1)
    im8b=.true.
    return
  endif
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
 
  if (bort_target_set() == 1) then
    call catch_bort_ufbmem_c(lunit,inew,iret,iunit)
    call bort_target_unset
    return
  endif
 
  ! Try to open BUFR file and set to initialize or concatenate
 
  call openbf(lunit,'IN',lunit)
 
  if(inew==0) then
    msgp(0) = 0
    munit = 0
    mlast = 0
    ndxts = 0
    ldxts = 0
    ndxm = 0
    ldxm = 0
  endif
 
  nmsg = msgp(0)
  iret = 0
  iflg = 0
  itim = 0
 
  ! Copy any BUFR dictionary table messages from the beginning of lunit into @ref moda_msgmem for possible later use.
  ! Note that such a table (if one exists) is already now in scope due to the prior call to subroutine openbf(), which
  ! in turn would have automatically called subroutines readdx(), rdbfdx() and makestab() for this table.
 
  itemp = ndxts
  call status(lunit,lun,il,im)
  call cewind_c(lun)
  call cpdxmm(lunit)
 
  ! If a table was indeed present at the beginning of the file, then set the flag to indicate that this table is now in scope.
 
  if ((itemp+1)==ndxts) ldxts = ndxts
 
  ! Transfer messages from file to memory and set message pointers
 
  do while (.true.)
    call rdmsgw(lunit,mgwa,ier)
    if(ier==-1) exit
    if(ier==-2) then
      write(bort_str,'("BUFRLIB: UFBMEM - ERROR READING MESSAGE NUMBER",I5," INTO MEMORY FROM UNIT",I3)') nmsg+1,lunit
      call bort(bort_str)
    endif
 
    if(idxmsg(mgwa)==1) then
      ! New "embedded" BUFR dictionary table messages have been found in this file.  Copy them into @ref moda_msgmem
      ! for later use.
      call backbufr_c(lun)  ! Backspace lunit
      call cpdxmm(lunit)
      cycle
    endif
 
    nmsg = nmsg+1
    if(nmsg>maxmsg) iflg = 1
    lmem = nmwrd(mgwa)
    if(lmem+mlast>maxmem) iflg = 2
 
    if(iflg==0) then
      iret = iret+1
      do i=1,lmem
        msgs(mlast+i) = mgwa(i)
      enddo
      msgp(0) = nmsg
      msgp(nmsg) = mlast+1
    else
      if(itim==0) then
        mlast0 = mlast
        itim=1
      endif
    endif
    mlast = mlast+lmem
  enddo
 
  if(iflg==1) then
    ! Emergency room treatment for maxmsg array overflow
    if(iprt>=0) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEM - THE NO. OF MESSAGES REQUIRED TO STORE ', &
        'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmsg, ') - INCOMPLETE READ'
      call errwrt(errstr)
      write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEM STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
      call errwrt(errstr)
      write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEM STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
      call errwrt(errstr)
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      call errwrt(' ')
    endif
    mlast=mlast0
  endif
 
  if(iflg==2) then
    ! Emergency room treatment for maxmem array overflow
    if(iprt>=0) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEM - THE NO. OF BYTES REQUIRED TO STORE ', &
        'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmem, ') - INCOMPLETE READ'
      call errwrt(errstr)
      write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEM STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
      call errwrt(errstr)
      write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEM STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
      call errwrt(errstr)
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      call errwrt(' ')
    endif
    mlast=mlast0
  endif
 
  if(iret==0) then
    call closbf(lunit)
  else
    if(munit/=0) call closbf(lunit)
    if(munit==0) munit = lunit
  endif
  iunit = munit
 
  return
end subroutine ufbmem
 
recursive subroutine ufbmex(lunit,lundx,inew,iret,mesg)
 
  use bufrlib
 
  use modv_vars, only: im8b, maxmem, maxmsg, iprt
 
  use moda_mgwa
  use moda_msgmem
 
  implicit none
 
  character*128 bort_str, errstr
 
  integer, intent(in) :: lunit, lundx, inew
  integer, intent(out) :: mesg(*), iret
  integer my_lunit, my_lundx, my_inew, nmesg, iflg, itim, ier, nmsg, lmem, i, mlast0, iupbs01, nmwrd, bort_target_set
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call x84(lundx,my_lundx,1)
    call x84(inew,my_inew,1)
    if (my_inew==0) then
      nmesg = 0
    else
      nmesg = msgp(0)
      call x84(mesg(1),mesg(1),nmesg)
    endif
    call ufbmex(my_lunit,my_lundx,my_inew,iret,mesg(1))
    call x48(mesg(1),mesg(1),nmesg+iret)
    call x48(iret,iret,1)
    im8b=.true.
    return
  endif
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
 
  if (bort_target_set() == 1) then
    call catch_bort_ufbmex_c(lunit,lundx,inew,iret,mesg)
    call bort_target_unset
    return
  endif
 
  ! Try to open BUFR file and set to initialize or concatenate
 
  call openbf(lunit,'IN',lundx)
 
  if(inew==0) then
    msgp(0) = 0
    munit = 0
    mlast = 0
    ndxts = 0
    ldxts = 0
    ndxm = 0
    ldxm = 0
  endif
 
  nmsg = msgp(0)
  iret = 0
  iflg = 0
  itim = 0
 
  ! Set some flags so that subsequent calls to the message reading routines will know there is a BUFR table in scope.
 
  ndxts = 1
  ldxts = 1
  ipmsgs(1) = 1
 
  ! Transfer messages from file to memory and set message pointers.
 
  do while (.true.)
    call rdmsgw(lunit,mgwa,ier)
    if(ier==-1) exit
    if(ier==-2) then
      write(bort_str,'("BUFRLIB: UFBMEX - ERROR READING MESSAGE NUMBER",I5," INTO MEMORY FROM UNIT",I3)') nmsg+1,lunit
      call bort(bort_str)
    endif
 
    nmsg = nmsg+1
    mesg(nmsg) = iupbs01(mgwa,'MTYP')
    if(nmsg>maxmsg) iflg = 1
    lmem = nmwrd(mgwa)
    if(lmem+mlast>maxmem) iflg = 2
 
    if(iflg==0) then
      iret = iret+1
      do i=1,lmem
        msgs(mlast+i) = mgwa(i)
      enddo
      msgp(0) = nmsg
      msgp(nmsg) = mlast+1
    else
      if(itim==0) then
        mlast0 = mlast
        itim=1
      endif
    endif
    mlast = mlast+lmem
  enddo
 
  if(iflg==1) then
    ! Emergency room treatment for maxmsg array overflow
    if(iprt>=0) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEX - THE NO. OF MESSAGES REQUIRED TO STORE ', &
        'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmsg, ') - INCOMPLETE READ'
      call errwrt(errstr)
      write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEX STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
      call errwrt(errstr)
      write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEX STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
      call errwrt(errstr)
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      call errwrt(' ')
    endif
    mlast=mlast0
  endif
 
  if(iflg==2) then
    ! Emergency room treatment for maxmem array overflow
    if(iprt>=0) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBMEX - THE NO. OF BYTES REQUIRED TO STORE ', &
        'ALL MESSAGES INTERNALLY EXCEEDS MAXIMUM (', maxmem, ') - INCOMPLETE READ'
      call errwrt(errstr)
      write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEX STORED ', mlast0, ' BYTES OUT OF ', mlast, '<<<'
      call errwrt(errstr)
      write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBMEX STORED ', msgp(0), ' MESSAGES OUT OF ', nmsg, '<<<'
      call errwrt(errstr)
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      call errwrt(' ')
    endif
    mlast=mlast0
  endif
 
  if(iret==0) then
    call closbf(lunit)
  else
    if(munit/=0) call closbf(lunit)
    if(munit==0) munit = lunit
  endif
 
  return
end subroutine ufbmex
 
recursive subroutine readmm(imsg,subset,jdate,iret)
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(inout) :: imsg
  integer, intent(out) :: jdate, iret
 
  character*8, intent(out) :: subset
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
    call x84(imsg,imsg,1)
    call readmm(imsg,subset,jdate,iret)
    call x48(imsg,imsg,1)
    call x48(jdate,jdate,1)
    call x48(iret,iret,1)
    im8b=.true.
    return
  endif
 
  call rdmemm(imsg,subset,jdate,iret)
 
  imsg = imsg+1
 
  return
end subroutine readmm
 
recursive integer function ireadmm(imsg,subset,idate) result(iret)
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(inout) :: imsg
  integer, intent(out) :: idate
 
  character*8, intent(out) :: subset
 
  ! Check for I8 integers.
 
  if(im8b) then
     im8b=.false.
     call x84(imsg,imsg,1)
     iret=ireadmm(imsg,subset,idate)
     call x48(imsg,imsg,1)
     call x48(idate,idate,1)
     im8b=.true.
     return
  endif
 
  call readmm(imsg,subset,idate,iret)
 
  return
end function ireadmm
 
recursive subroutine rdmemm(imsg,subset,jdate,iret)
 
  use bufrlib
 
  use modv_vars, only: im8b, iprt
 
  use moda_msgcwd
  use moda_bitbuf
  use moda_mgwa
  use moda_msgmem
 
  implicit none
 
  integer, intent(in) :: imsg
  integer, intent(out) :: jdate, iret
  integer my_imsg, lun, il, im, ii, jj, kk, nwrd, iptr, lptr, ier, bort_target_set
 
  character*128 bort_str, errstr
  character*8, intent(out) :: subset
  character*9 csubset
 
  logical known
 
  ! Check for I8 integers
 
  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
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
 
  if (bort_target_set() == 1) then
    call catch_bort_rdmemm_c(imsg,csubset,jdate,len(csubset),iret)
    subset(1:8) = csubset(1:8)
    call bort_target_unset
    return
  endif
 
  ! Check the message request and file status
 
  call status(munit,lun,il,im)
  call wtstat(munit,lun,il,1)
  iret = 0
 
  if(imsg==0 .or.imsg>msgp(0)) then
    call wtstat(munit,lun,il,0)
    if(iprt>=1) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      if(imsg==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
    return
  endif
 
  ! Determine which table applies to this message.
 
  known = .false.
  jj = ndxts
  do while ((.not.known).and.(jj>=1))
    if (ipmsgs(jj)<=imsg) then
      known = .true.
    else
      jj = jj - 1
    endif
  enddo
  if (.not.known) then
    write(bort_str,'("BUFRLIB: RDMEMM - UNKNOWN DX TABLE FOR REQUESTED MESSAGE #",I5)') imsg
    call bort(bort_str)
  endif
 
  ! Is this table the one that is currently in scope?
 
  if (jj/=ldxts) then
 
    ! No, so reset the software to use the proper table.
 
    if(iprt>=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)
 
    ! Store each of the DX dictionary messages which constitute this table.
 
    do ii = ifdxts(jj), (ifdxts(jj)+icdxts(jj)-1)
      if (ii==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
 
    ! Rebuild the internal jump/link table.
 
    call makestab
    ldxts = jj
  endif
 
  ! Read memory message number imsg into a message buffer.
 
  iptr = msgp(imsg)
  if(imsg<msgp(0)) lptr = msgp(imsg+1)-iptr
  if(imsg==msgp(0)) lptr = mlast-iptr+1
  iptr = iptr-1
 
  do ii=1,lptr
    mbay(ii,lun) = msgs(iptr+ii)
  enddo
 
  ! Parse the message section contents.
 
  call cktaba(lun,subset,jdate,ier)
  nmsg(lun) = imsg
 
  return
end subroutine rdmemm
 
recursive subroutine rdmems(isub,iret)
 
  use bufrlib
 
  use modv_vars, only: im8b, iprt
 
  use moda_msgcwd
  use moda_unptyp
  use moda_bitbuf
  use moda_msgmem
 
  implicit none
 
  integer, intent(in) :: isub
  integer, intent(out) :: iret
  integer my_isub, lun, il, im, mbym, nbyt, i, iupb, bort_target_set
 
  character*128 bort_str, errstr
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(isub,my_isub,1)
    call rdmems(my_isub,iret)
    call x48(iret,iret,1)
    im8b=.true.
    return
  endif
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
 
  if (bort_target_set() == 1) then
    call catch_bort_rdmems_c(isub,iret)
    call bort_target_unset
    return
  endif
 
  ! Check the message request and file status
 
  call status(munit,lun,il,im)
  if(im==0) call bort('BUFRLIB: RDMEMS - A MEMORY MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
  if(nsub(lun)/=0) then
    write(bort_str,'("BUFRLIB: RDMEMS - UPON ENTRY, SUBSET POINTER IN MEMORY MESSAGE IS NOT AT BEGINNING (",I3," '// &
      'SUBSETS HAVE BEEN READ, SHOULD BE 0)")') nsub(lun)
    call bort(bort_str)
  endif
 
  if(isub>msub(lun)) then
    if(iprt>=0) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      write ( unit=errstr, fmt='(A,I5,A,A,I5,A)' ) 'BUFRLIB: RDMEMS - REQ. SUBSET #', isub, ' (= 1st INPUT ', &
        'ARG.) > # OF SUBSETS IN MEMORY MESSAGE (', msub(lun), ')'
      call errwrt(errstr)
      call errwrt('RETURN WITH IRET = -1')
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      call errwrt(' ')
    endif
    iret = -1
    return
  endif
 
  mbym = mbyt(lun)
  nbyt = 0
 
  ! Position to subset number isub in memory message
 
  if(msgunp(lun)==0) then
    nsub(lun) = isub-1
    do i=1,isub-1
      mbyt(lun) = mbyt(lun) + iupb(mbay(1,lun),mbyt(lun)+1,16)
    enddo
  elseif(msgunp(lun)==1) then
    ! message with "standard" Section 3
    do i=1,isub-1
      call readsb(munit,iret)
    enddo
  else
    ! compressed message
    nsub(lun) = isub-1
  endif
 
  ! Now read subset number isub from memory message
 
  call readsb(munit,iret)
  if(iret/=0) call bort('BUFRLIB: RDMEMS - CALL TO ROUTINE READSB RETURNED WITH IRET = -1 (EITHER MEMORY MESSAGE '// &
     'NOT OPEN OR ALL SUBSETS IN MESSAGE READ')
 
  ! Reset subset pointer back to zero (beginning of message) and return
 
  mbyt(lun) = mbym
  nsub(lun) = 0
 
  return
end subroutine rdmems
 
subroutine cpdxmm( lunit )
 
  use bufrlib
 
  use modv_vars, only: mxdxts, iprt
 
  use moda_mgwa
  use moda_msgmem
 
  implicit none
 
  integer, intent(in) :: lunit
  integer ict, lun, il, im, ier, j, lmem, idxmsg, iupbs3, nmwrd
 
  character*128 errstr
 
  logical done
 
  if ( ndxts >= mxdxts ) call bort('BUFRLIB: CPDXMM - MXDXTS OVERFLOW')
 
  ict = 0
  done = .false.
  call status(lunit,lun,il,im)
 
  ! Read a complete dictionary table from lunit, as a set of one or more DX dictionary messages.
 
  do while ( .not. done )
    call rdmsgw ( lunit, mgwa, ier )
    if ( ier == -2 ) call bort('BUFRLIB: CPDXMM - UNEXPECTED READ ERROR')
    if ( ier == -1 ) then
 
      ! Don't abort for an end-of-file condition, since it may be possible for a file to end with dictionary messages.
      ! Instead, backspace the file pointer and let the calling routine diagnose the end-of-file condition and deal with
      ! it as it sees fit.
 
      call backbufr_c(lun)
      done = .true.
    else if ( idxmsg(mgwa) /= 1 ) then
 
      ! This is a non-DX dictionary message.  Assume we've reached the end of the dictionary table, and backspace lunit so
      ! that the next read (e.g. in the calling routine) will get this same message.
 
      call backbufr_c(lun)
      done = .true.
    else if ( iupbs3(mgwa,'nsub') == 0 ) then
 
      ! This is a DX dictionary message, but it doesn't contain any actual dictionary information.  Assume we've reached the
      ! end of the dictionary table.
 
      done = .true.
    else
 
      ! Store this message into @ref moda_msgmem.
 
      ict = ict + 1
      if ( ( ndxm + ict ) > mxdxm ) call bort('BUFRLIB: CPDXMM - MXDXM OVERFLOW')
      ipdxm(ndxm+ict) = ldxm + 1
      lmem = nmwrd(mgwa)
      if ( ( ldxm + lmem ) > mxdxw ) call bort('BUFRLIB: CPDXMM - MXDXW OVERFLOW')
      do j = 1, lmem
        mdx(ldxm+j) = mgwa(j)
      enddo
      ldxm = ldxm + lmem
    endif
  enddo
 
  ! Update the table information within @ref moda_msgmem.
 
  if ( ict > 0 ) then
    ifdxts(ndxts+1) = ndxm + 1
    icdxts(ndxts+1) = ict
    ipmsgs(ndxts+1) = msgp(0) + 1
    ndxm = ndxm + ict
    ndxts = ndxts + 1
    if ( iprt >= 2 ) then
      call errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
      write ( unit=errstr, fmt='(A,I3,A,I3,A)') 'BUFRLIB: CPDXMM - STORED NEW DX TABLE #', ndxts, &
        ' CONSISTING OF ', ict, ' MESSAGES'
      call errwrt(errstr)
      call errwrt('+++++++++++++++++++++++++++++++++++++++++++++')
      call errwrt(' ')
    endif
  endif
 
  return
end subroutine cpdxmm
 
recursive subroutine ufbmms(imsg,isub,subset,jdate)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
  use moda_msgmem
 
  implicit none
 
  integer, intent(in) :: imsg, isub
  integer, intent(out) :: jdate
  integer my_imsg, my_isub, lun, il, im, iret, bort_target_set
 
  character*8, intent(out) :: subset
  character*128 bort_str
  character*9 csubset
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(imsg,my_imsg,1)
    call x84(isub,my_isub,1)
    call ufbmms(my_imsg,my_isub,subset,jdate)
    call x48(jdate,jdate,1)
    im8b=.true.
    return
  endif
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
 
  if (bort_target_set() == 1) then
    call catch_bort_ufbmms_c(imsg,isub,csubset,jdate,len(csubset))
    subset(1:8) = csubset(1:8)
    call bort_target_unset
    return
  endif
 
  ! Read subset #isub from memory message #imsg
 
  call rdmemm(imsg,subset,jdate,iret)
  if(iret<0) then
    if(imsg>0)  then
      write(bort_str,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF '// &
        'MESSAGES IN MEMORY (",I5,")")') imsg,msgp(0)
    else
      write(bort_str,'("BUFRLIB: UFBMMS - REQUESTED MEMORY MESSAGE NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")')
    endif
    call bort(bort_str)
  endif
  call rdmems(isub,iret)
  if(iret/=0) then
    call status(munit,lun,il,im)
    write(bort_str,'("BUFRLIB: UFBMMS - REQ. SUBSET NUMBER TO READ IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") '// &
      'IN THE REG. MEMORY MESSAGE (",I5,")")') isub,msub(lun),imsg
    call bort(bort_str)
  endif
 
  return
end subroutine ufbmms
 
recursive subroutine ufbmns(irep,subset,idate)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_msgmem
 
  implicit none
 
  integer, intent(in) :: irep
  integer, intent(out) :: idate
  integer my_irep, imsg, jrep, iret, ireadmm, nmsub, bort_target_set
 
  character*8, intent(out) :: subset
  character*128 bort_str
  character*9 csubset
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(irep,my_irep,1)
    call ufbmns(my_irep,subset,idate)
    call x48(idate,idate,1)
    im8b=.true.
    return
  endif
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
 
  if (bort_target_set() == 1) then
    call catch_bort_ufbmns_c(irep,csubset,idate,len(csubset))
    subset(1:8) = csubset(1:8)
    call bort_target_unset
    return
  endif
 
  jrep = 0
  imsg = 1
 
  ! Read subset #irep
 
  do while(ireadmm(imsg,subset,idate)==0)
    if(jrep+nmsub(munit)>=irep) then
       call rdmems(irep-jrep,iret)
       return
    endif
    jrep = jrep+nmsub(munit)
  enddo
 
  write(bort_str,'("BUFRLIB: UFBMNS - REQ. SUBSET NO. TO READ IN (",I5,") EXCEEDS TOTAL NO. OF SUBSETS IN THE COLLECTION '// &
    'OF MEMORY MESSAGES (",I5,")")') irep,jrep
  call bort(bort_str)
end subroutine ufbmns
 
recursive subroutine ufbrms(imsg,isub,usr,i1,i2,iret,str)
 
  use bufrlib
 
  use modv_vars, only: im8b, iprt
 
  use moda_msgcwd
  use moda_msgmem
 
  implicit none
 
  integer, intent(in) :: imsg, isub, i1, i2
  integer, intent(out) :: iret
  integer my_imsg, my_isub, my_i1, my_i2, jdate, lun, il, im, lcstr, bort_target_set
 
  real*8, intent(out) :: usr(i1,i2)
 
  character*(*), intent(in) :: str
  character*128 bort_str, errstr
  character*90 cstr
  character*8 subset
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(imsg,my_imsg,1)
    call x84(isub,my_isub,1)
    call x84(i1,my_i1,1)
    call x84(i2,my_i2,1)
    call ufbrms(my_imsg,my_isub,usr,my_i1,my_i2,iret,str)
    call x48(iret,iret,1)
    im8b=.true.
    return
  endif
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
  if (bort_target_set() == 1) then
    call strsuc(str,cstr,lcstr)
    call catch_bort_ufbrms_c(imsg,isub,usr,i1,i2,iret,cstr,lcstr)
    call bort_target_unset
    return
  endif
 
  iret = 0
  if(i1<=0) then
    if(iprt>=0) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBRMS - 4th ARG. (INPUT) IS  0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
      call errwrt(errstr)
      call errwrt(str)
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      call errwrt(' ')
    endif
    return
  elseif(i2<=0) then
    if(iprt>=0) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      errstr = .LE.'BUFRLIB: UFBRMS - 5th ARG. (INPUT) IS  0, SO RETURN WITH 6th ARG. (IRET) = 0; 7th ARG. (STR) ='
      call errwrt(errstr)
      call errwrt(str)
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      call errwrt(' ')
    endif
    return
  endif
 
  ! Read requested values from subset #isub within memory message #imsg
 
  call rdmemm(imsg,subset,jdate,iret)
  if(iret<0) then
    if(imsg>0)  then
      write(bort_str,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE NUMBER TO READ IN (",I5,") EXCEEDS THE NUMBER OF '// &
        'MESSAGES IN MEMORY (",I5,")")') imsg,msgp(0)
    else
      write(bort_str,'("BUFRLIB: UFBRMS - REQUESTED MEMORY MESSAGE NUMBER TO READ IN IS ZERO - THIS IS NOT VALID")')
    endif
    call bort(bort_str)
  endif
  call rdmems(isub,iret)
  if(iret/=0) then
    call status(munit,lun,il,im)
    write(bort_str,'("BUFRLIB: UFBRMS - REQ. SUBSET NUMBER TO READ IN (",I3,") EXCEEDS THE NUMBER OF SUBSETS (",I3,") '// &
      'IN THE REG. MEMORY MESSAGE (",I5,")")') isub,msub(lun),imsg
    call bort(bort_str)
  endif
 
  call ufbint(munit,usr,i1,i2,iret,str)
 
  return
end subroutine ufbrms
 
recursive subroutine ufbtam(tab,i1,i2,iret,str)
 
  use bufrlib
 
  use modv_vars, only: im8b, bmiss, iprt
 
  use moda_usrint
  use moda_msgcwd
  use moda_bitbuf
  use moda_msgmem
  use moda_tables
 
  implicit none
 
  character*(*), intent(in) :: str
  character*128 bort_str, errstr
  character*90 cstr
  character*10 tgs(100)
  character*8 subset, cval
 
  integer*8 mps, ival
  integer, intent(in) :: i1, i2
  integer, intent(out) :: iret
  integer maxtg, nnod, ncon, nods, nodc, ivls, kons, my_i1, my_i2, i, irec, isub, itbl, lun, il, im, jdate, mret, &
    kbit, mbit, nbit, n, node, imsg, kmsg, nrep, ntg, nbyt, nbmp, nmsub, lcstr, bort_target_set
 
  real*8, intent(out) :: tab(i1,i2)
  real*8 rval, ups
 
  common /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
 
  equivalence(cval,rval)
 
  data maxtg /100/
 
  ! Statement function
  mps(node) = 2_8**(ibt(node))-1
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(i1,my_i1,1)
    call x84(i2,my_i2,1)
    call ufbtam(tab,my_i1,my_i2,iret,str)
    call x48(iret,iret,1)
    im8b=.true.
    return
  endif
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
  if (bort_target_set() == 1) then
    call strsuc(str,cstr,lcstr)
    call catch_bort_ufbtam_c(tab,i1,i2,iret,cstr,lcstr)
    call bort_target_unset
    return
  endif
 
  iret = 0
 
  if(msgp(0)==0) return
 
  tab(1:i1,1:i2) = bmiss
 
  ! Check for special tags in string
 
  call parstr(str,tgs,maxtg,ntg,' ',.true.)
  irec = 0
  isub = 0
  itbl = 0
  do i=1,ntg
    if(tgs(i)=='IREC') irec = i
    if(tgs(i)=='ISUB') isub = i
    if(tgs(i)=='ITBL') itbl = i
  enddo
 
  call status(munit,lun,il,im)
 
  ! Cycle through all of the memory messages in the internal arrays
 
  outer: do imsg=1,msgp(0)
    call rdmemm(imsg,subset,jdate,mret)
    if(mret<0) then
      write(bort_str,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') imsg
      call bort(bort_str)
    endif
 
    call string(str,lun,i1,0)
    if(irec>0) nods(irec) = 0
    if(isub>0) nods(isub) = 0
    if(itbl>0) nods(itbl) = 0
 
    ! Process all the subsets in the memory message
 
    do while (nsub(lun)<msub(lun))
      if(iret+1>i2) then
        ! Emergency room treatment for array overflow
        call rdmemm(0,subset,jdate,mret)
        nrep = 0
        do kmsg=1,msgp(0)
          call rdmemm(kmsg,subset,jdate,mret)
          if(mret<0) then
            write(bort_str,'("BUFRLIB: UFBTAM - HIT END-OF-FILE READING MESSAGE NUMBER",I5," IN INTERNAL MEMORY")') kmsg
            call bort(bort_str)
          endif
          nrep = nrep+nmsub(munit)
        enddo
        if(iprt>=0) then
          call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
          write ( unit=errstr, fmt='(A,A,I8,A,A)' ) 'BUFRLIB: UFBTAM - THE NO. OF DATA SUBSETS IN MEMORY ', &
            .GT.'IS  LIMIT OF ', i2, ' IN THE 3RD ARG. (INPUT) - INCOMPLETE READ'
          call errwrt(errstr)
          write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBTAM STORED ', iret, ' REPORTS OUT OF ', nrep, '<<<'
          call errwrt(errstr)
          call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
          call errwrt(' ')
        endif
        exit outer
      endif
 
      iret = iret+1
 
      do i=1,nnod
        nods(i) = abs(nods(i))
      enddo
 
      call usrtpl(lun,1,1)
      mbit = mbyt(lun)*8+16
      nbit = 0
      n = 1
 
      inner: do while(n+1<=nval(lun))
        n = n+1
        node = inv(n,lun)
        mbit = mbit+nbit
        nbit = ibt(node)
        if(itp(node)==1) then
          call upb8(ival,nbit,mbit,mbay(1,lun))
          nbmp=int(ival)
          call usrtpl(lun,n,nbmp)
        endif
        do i=1,nnod
          if(nods(i)==node) then
            if(itp(node)==1) then
              call upb8(ival,nbit,mbit,mbay(1,lun))
              tab(i,iret) = ival
            elseif(itp(node)==2) then
              call upb8(ival,nbit,mbit,mbay(1,lun))
              if(ival<mps(node)) tab(i,iret) = ups(ival,node)
            elseif(itp(node)==3) then
              cval = ' '
              kbit = mbit
              call upc(cval,nbit/8,mbay(1,lun),kbit,.true.)
              tab(i,iret) = rval
            endif
            nods(i) = -nods(i)
            cycle inner
          endif
        enddo
        do i=1,nnod
          if(nods(i)>0) cycle inner
        enddo
      enddo inner
 
      ! Update the subset pointers before next read
 
      ibit = mbyt(lun)*8
      call upb(nbyt,16,mbay(1,lun),ibit)
      mbyt(lun) = mbyt(lun) + nbyt
      nsub(lun) = nsub(lun) + 1
      if(irec>0) tab(irec,iret) = nmsg(lun)
      if(isub>0) tab(isub,iret) = nsub(lun)
      if(itbl>0) tab(itbl,iret) = ldxts
    enddo
 
  enddo outer
 
  ! Reset the memory file
  call rdmemm(0,subset,jdate,mret)
 
  return
end subroutine ufbtam