readwritemg.F90

Go to the documentation of this file.

 
 
recursive subroutine readmg(lunxx,subset,jdate,iret)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
  use moda_sc3bfr
  use moda_bitbuf
 
  implicit none
 
  integer, intent(in) :: lunxx
  integer, intent(out) :: jdate, iret
  integer iprt, my_lunxx, lunit, lun, il, im, ier, idxmsg
 
  character*8, intent(out) :: subset
  character*128 errstr
 
  common /quiet/ iprt
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(lunxx,my_lunxx,1)
    call readmg(my_lunxx,subset,jdate,iret)
    call x48(jdate,jdate,1)
    call x48(iret,iret,1)
 
    im8b=.true.
    return
  endif
 
  iret = 0
  lunit = abs(lunxx)
 
  ! Check the file status
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: READMG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
  if(il>0) call bort('BUFRLIB: READMG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
  call wtstat(lunit,lun,il,1)
 
  ! Read a message into the internal message buffer
 
  do while (.true.)
    call rdmsgw(lunit,mbay(1,lun),ier)
    if(ier==-1) then
      ! EOF on attempted read
      call wtstat(lunit,lun,il,0)
      inode(lun) = 0
      idate(lun) = 0
      subset = ' '
      jdate = 0
      iret = -1
      return
    endif
 
    ! Parse the message section contents
    if(isc3(lun)/=0) call reads3(lun)
    call cktaba(lun,subset,jdate,iret)
 
    ! Check for a dictionary message
    if(idxmsg(mbay(1,lun))/=1) return
 
    ! This is an internal dictionary message that was generated by the NCEPLIBS-bufr software.
    if(isc3(lun)/=0) return
 
    ! Section 3 decoding isn't being used, so backspace the file pointer and then use subroutine rdbfdx() to read in
    ! all such dictionary messages (they should be stored consecutively!) and reset the internal tables.
    call backbufr_c(lun)
    call rdbfdx(lunit,lun)
    if(iprt>=1) then
      call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      errstr = 'BUFRLIB: READMG - INTERNAL DICTIONARY MESSAGE READ; ACCOUNT FOR IT THEN READ IN NEXT MESSAGE WITHOUT RETURNING'
      call errwrt(errstr)
      call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      call errwrt(' ')
    endif
  enddo
 
end subroutine readmg
 
recursive integer function ireadmg(lunit,subset,idate) result(iret)
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(in) :: lunit
  integer, intent(out) :: idate
  integer my_lunit
 
  character*8, intent(out) :: subset
 
  ! Check for I8 integers
 
  if(im8b) then
     im8b=.false.
 
     call x84(lunit,my_lunit,1)
     iret=ireadmg(my_lunit,subset,idate)
     call x48(idate,idate,1)
 
     im8b=.true.
     return
  endif
 
  call readmg(lunit,subset,idate,iret)
 
  return
end function ireadmg
 
recursive subroutine readerme(mesg,lunit,subset,jdate,iret)
 
  use modv_vars, only: mxmsgl, im8b, nbytw
 
  use moda_sc3bfr
  use moda_idrdm
  use moda_bitbuf
 
  implicit none
 
  integer, intent(in) :: lunit, mesg(*)
  integer, intent(out) :: jdate, iret
  integer iprt, my_lunit, iec0(2), lun, il, im, ii, lnmsg, lmsg, idxmsg, iupbs3
 
  character*8, intent(out) :: subset
  character*8 sec0
  character*128 errstr, bort_str
 
  logical endtbl
 
  equivalence(sec0,iec0)
 
  common /quiet/ iprt
 
  ! Check for I8 integers
 
  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
 
  ! Check the file status
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: READERME - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
  if(il>0) call bort('BUFRLIB: READERME - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
  call wtstat(lunit,lun,il, 1)
 
  ! Copy the input message into the internal message buffer
 
  iec0(1) = mesg(1)
  iec0(2) = mesg(2)
  lnmsg = lmsg(sec0)
  if(lnmsg*nbytw>mxmsgl) then
    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)
  endif
  do ii=1,lnmsg
    mbay(ii,lun) = mesg(ii)
  enddo
 
  ! Confirm that the first 4 bytes of SEC0 contain 'BUFR'.
 
  if(sec0(1:4)/='BUFR') &
    call bort('BUFRLIB: READERME - FIRST 4 BYTES READ FROM RECORD NOT "BUFR", DOES NOT CONTAIN BUFR DATA')
 
  ! Parse the message section contents
 
  if(isc3(lun)/=0) call reads3(lun)
  call cktaba(lun,subset,jdate,iret)
  if(isc3(lun)/=0) return
 
  ! Check for a DX dictionary message
 
  ! A new DX dictionary table can be passed in as a consecutive set of DX dictionary messages.  Each message should be passed
  ! in one at a time, via input argument mesg during consecutive calls to this subroutine, and all such messages will be
  ! treated as a single dictionary table up until the next message is passed in which either contains no data subsets or
  ! else is a non-DX dictionary message.
 
  endtbl = .false.
  if(idxmsg(mbay(1,lun))==1) then
    ! This is a DX dictionary message that was generated by the NCEPLIBS-bufr software.
    if(iupbs3(mbay(1,lun),'NSUB')==0) then
      ! But it doesn't contain any actual dictionary information, so assume we've reached the end of the dictionary table.
      if(idrdm(lun)>0) then
        endtbl = .true.
      endif
    else
      if(idrdm(lun)==0) then
        ! This is the first DX dictionary message that is part of a new dictionary table.
        call dxinit(lun,0)
      endif
      idrdm(lun) = idrdm(lun) + 1
      call stbfdx(lun,mbay(1,lun))
    endif
  else if(idrdm(lun)>0) then
    ! This is the first non-DX dictionary message received following a string of DX dictionary messages, so assume we've
    ! reached the end of the dictionary table.
    endtbl = .true.
  endif
 
  if(endtbl) then
    if ( iprt >= 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
 
  return
end subroutine readerme
 
subroutine rdmsgw(lunit,mesg,iret)
 
  use bufrlib
 
  use modv_vars, only: mxmsgld4
 
  implicit none
 
  integer, intent(in) :: lunit
  integer, intent(out) :: mesg(*), iret
  integer lun, il, im
 
  call status(lunit,lun,il,im)
  iret = -2
  do while (iret<=-2)
     iret = crdbufr_c(lun,mesg,mxmsgld4)
     if(iret==-3) call errwrt('BUFRLIB: RDMSGW - SKIPPING OVERLARGE MESSAGE')
     if(iret==-2) call errwrt('BUFRLIB: RDMSGW - SKIPPING CORRUPTED MESSAGE')
  end do
 
  return
end subroutine rdmsgw
 
recursive subroutine openmb(lunit,subset,jdate)
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
 
  implicit none
 
  integer, intent(in) :: lunit, jdate
  integer my_lunit, my_jdate, lun, il, im, mtyp, mstb, inod, i4dy
 
  character*(*), intent(in) :: subset
 
  logical open
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(lunit,my_lunit,1)
    call x84(jdate,my_jdate,1)
    call openmb(my_lunit,subset,my_jdate)
 
    im8b=.true.
    return
  endif
 
  ! Check the file status
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
  if(il<0) call bort('BUFRLIB: OPENMB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
 
  ! Get some subset particulars
 
  call nemtba(lun,subset,mtyp,mstb,inod)
  open = im==0 .or. inod/=inode(lun) .or. i4dy(jdate)/=idate(lun)
 
  ! Maybe(?) open a new or different type of message
 
  if(open) then
    call closmg(lunit)
    call wtstat(lunit,lun,il, 1)
    inode(lun) = inod
    idate(lun) = i4dy(jdate)
    ! Initialize the open message
    call msgini(lun)
    call usrtpl(lun,1,1)
  endif
 
  return
end subroutine openmb
 
recursive subroutine openmg(lunit,subset,jdate)
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
 
  implicit none
 
  integer, intent(in) :: lunit, jdate
  integer my_lunit, my_jdate, lun, il, im, mtyp, mstb, inod, i4dy
 
  character*(*), intent(in) :: subset
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(lunit,my_lunit,1)
    call x84(jdate,my_jdate,1)
    call openmg(my_lunit,subset,my_jdate)
 
    im8b=.true.
    return
  endif
 
  ! Check the file status
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
  if(il<0) call bort('BUFRLIB: OPENMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
  if(im/=0) call closmg(lunit)
  call wtstat(lunit,lun,il, 1)
 
  ! Get some subset particulars
 
  call nemtba(lun,subset,mtyp,mstb,inod)
  inode(lun) = inod
  idate(lun) = i4dy(jdate)
 
  ! Initialize the open message
 
  call msgini(lun)
  call usrtpl(lun,1,1)
 
  return
end subroutine openmg
 
recursive subroutine closmg(lunin)
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
  use moda_msglim
  use moda_bitbuf
 
  implicit none
 
  integer, intent(in) :: lunin
  integer my_lunin, lunit, lun, il, im
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(lunin,my_lunin,1)
    call closmg(my_lunin)
 
    im8b=.true.
    return
  endif
 
  ! Check the file status
 
  lunit = abs(lunin)
  call status(lunit,lun,il,im)
  if(lunit/=lunin) msglim(lun) = 0
  if(il==0) call bort('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
  if(il<0) call bort('BUFRLIB: CLOSMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
  if(im/=0) then
    if(nsub(lun)>0) then
      call msgwrt(lunit,mbay(1,lun),mbyt(lun))
    else if(nsub(lun)==0.and.nmsg(lun)<msglim(lun)) then
      call msgwrt(lunit,mbay(1,lun),mbyt(lun))
    else if(nsub(lun)<0) then
      call wrcmps(-lunit)
    endif
  endif
  call wtstat(lunit,lun,il,0)
 
  return
end subroutine closmg
 
subroutine msgwrt(lunit,mesg,mgbyt)
 
  use bufrlib
 
  use modv_vars, only: mxmsgld4
 
  use moda_nulbfr
  use moda_bufrmg
  use moda_mgwa
  use moda_mgwb
  use moda_s01cm
  use moda_tnkrcp
  use moda_msgstd
 
  implicit none
 
  integer, intent(in) :: lunit, mgbyt, mesg(*)
  integer iprt, iec0(2), mbyt, ibit, kbit, ii, jj, len0, len1, len2, len3, len4, l5, iad4, iad5, lun, il, im, npbyt, mwrd, &
    nmwrd, iupbs01, idxmsg
 
  character*128 errstr
  character*4 bufr, sevn
 
  common /quiet/ iprt
 
  data bufr /'BUFR'/
  data sevn /'7777'/
 
  ! Make a local copy of the input message for use within this subroutine, since internal calls to any or all of the
  ! subroutines stndrd(), cnved4(), pkbs1(), atrcpt(), etc. may end up modifying the message before it finally gets
  ! written out to lunit.
 
  mbyt = mgbyt
 
  iec0(1) = mesg(1)
  iec0(2) = mesg(2)
  ibit = 32
  call pkb(mbyt,24,iec0,ibit)
 
  do ii = 1, nmwrd(iec0)
    mgwa(ii) = mesg(ii)
  enddo
 
  ! Overwrite any values within Section 0 or Section 1 that were requested via previous calls to pkvs01().  If a request
  ! was made to change the BUFR edition number to 4, then actually convert the message as well.
 
  if(ns01v>0) then
    do jj=1,ns01v
      if(cmnem(jj)=='BEN') then
        if(ivmnem(jj)==4) then
          ! Install Section 0 byte count for use by cnved4()
          ibit = 32
          call pkb(mbyt,24,mgwa,ibit)
          call cnved4(mgwa,mxmsgld4,mgwb)
          ! Compute mbyt for the new edition 4 message
          mbyt = iupbs01(mgwb,'LENM')
          ! Copy the mgwb array back into mgwa
          do ii = 1, nmwrd(mgwb)
            mgwa(ii) = mgwb(ii)
          enddo
        endif
      else
        ! Overwrite the requested value
        call pkbs1(ivmnem(jj),mgwa,cmnem(jj))
      endif
    enddo
  endif
 
  ! Standardize the message if requested via module @ref moda_msgstd.  However, we don't want to do this if the message
  ! contains DX BUFR table information, because in that case it's already standard.
 
  if ( ( csmf=='Y' ) .and. ( idxmsg(mgwa)/=1 ) ) then
    ! Install Section 0 byte count and Section 5 '7777' into the original message.  This is necessary because
    ! subroutine stndrd() requires a complete and well-formed BUFR message as its input.
    ibit = 32
    call pkb(mbyt,24,mgwa,ibit)
    ibit = (mbyt-4)*8
    call pkc(sevn,4,mgwa,ibit)
    call stndrd(lunit,mgwa,mxmsgld4,mgwb)
    ! Compute mbyt for the new standardized message
    mbyt = iupbs01(mgwb,'LENM')
    ! Copy the mgwb array back into mgwa
    do ii = 1, nmwrd(mgwb)
      mgwa(ii) = mgwb(ii)
    enddo
  endif
 
  ! Append the tank receipt time to Section 1 if requested via module @ref moda_tnkrcp, unless the message contains
  ! DX BUFR table information.
 
  if ( ( ctrt=='Y' ) .and. ( idxmsg(mgwa)/=1 ) ) then
    ! Install Section 0 byte count for use by subroutine atrcpt()
    ibit = 32
    call pkb(mbyt,24,mgwa,ibit)
    call atrcpt(mgwa,mxmsgld4,mgwb)
    ! Compute mbyt for the revised message
    mbyt = iupbs01(mgwb,'LENM')
    ! Copy the mgwb array back into mgwa
    do ii = 1, nmwrd(mgwb)
      mgwa(ii) = mgwb(ii)
    enddo
  endif
 
  ! Get the section lengths.
 
  call getlens(mgwa,4,len0,len1,len2,len3,len4,l5)
 
  ! Depending on the edition number of the message, we need to ensure that each section within the message has an even
  ! number of bytes.
 
  if(iupbs01(mgwa,'BEN')<4) then
    if(mod(len1,2)/=0) call bort ('BUFRLIB: MSGWRT - LENGTH OF SECTION 1 IS NOT A MULTIPLE OF 2')
    if(mod(len2,2)/=0) call bort ('BUFRLIB: MSGWRT - LENGTH OF SECTION 2 IS NOT A MULTIPLE OF 2')
    if(mod(len3,2)/=0) call bort ('BUFRLIB: MSGWRT - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2')
    if(mod(len4,2)/=0) then
      ! Pad Section 4 with an additional byte that is zeroed out
      iad4 = len0+len1+len2+len3
      iad5 = iad4+len4
      ibit = iad4*8
      len4 = len4+1
      call pkb(len4,24,mgwa,ibit)
      ibit = iad5*8
      call pkb(0,8,mgwa,ibit)
      mbyt = mbyt+1
    endif
  endif
 
  ! Write Section 0 byte count and Section 5
 
  ibit = 0
  call pkc(bufr, 4,mgwa,ibit)
  call pkb(mbyt,24,mgwa,ibit)
 
  kbit = (mbyt-4)*8
  call pkc(sevn, 4,mgwa,kbit)
 
  ! Zero out the extra bytes which will be written. Note that the BUFR message is stored within the integer array mgwa(*),
  ! (rather than within a character array), so we need to make sure that the "7777" Is followed by zeroed-out bytes up to
  ! the boundary of the last machine word that will be written out.
 
  call padmsg(mgwa,mxmsgld4,npbyt)
 
  ! Write the message plus padding to a word boundary if null(lun) = 0
 
  mwrd = nmwrd(mgwa)
  call status(lunit,lun,il,im)
  if(null(lun)==0) then
    call blocks(mgwa,mwrd)
    call cwrbufr_c(lun,mgwa,mwrd)
  endif
 
  if(iprt>=2) then
    call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
    write ( unit=errstr, fmt='(A,I4,A,I7)') 'BUFRLIB: MSGWRT: LUNIT =', lunit, ', BYTES =', mbyt+npbyt
    call errwrt(errstr)
    call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
    call errwrt(' ')
  endif
 
  ! Save a memory copy of this message, unless it's a DX message.
 
  if(idxmsg(mgwa)/=1) then
    ! Store a copy of this message within module @ref moda_bufrmg, for possible later retrieval during a future call to
    ! subroutine writsa()
    msglen(lun) = mwrd
    do ii=1,msglen(lun)
      msgtxt(ii,lun) = mgwa(ii)
    enddo
  endif
 
  return
end subroutine msgwrt
 
subroutine msgini(lun)
 
  use moda_msgcwd
  use moda_ufbcpl
  use moda_bitbuf
  use moda_tables
 
  implicit none
 
  integer, intent(in) :: lun
  integer ibct, ipd1, ipd2, ipd3, ipd4, nby0, nby1, nby2, nby3, nby4, nby5, nbyt, mtyp, msbt, inod, isub, iret, &
    mcen, mear, mmon, mday, mour, mmin, mbit
 
  character*128 bort_str
  character*8 subtag
  character*4 bufr, sevn
  character tab
 
  data bufr /'BUFR'/
  data sevn /'7777'/
 
  common /padesc/ ibct,ipd1,ipd2,ipd3,ipd4
  common /msgptr/ nby0,nby1,nby2,nby3,nby4,nby5
 
  ! Get the message tag and type, and break up the date
 
  subtag = tag(inode(lun))(1:8)
  call nemtba(lun,subtag,mtyp,msbt,inod)
  if(inode(lun)/=inod) then
    write(bort_str,'("BUFRLIB: MSGINI - MISMATCH BETWEEN INODE (=",I7,") & POSITIONAL INDEX, INOD (",I7,") '// &
      'OF SUBTAG (",A,") IN DICTIONARY")') inode(lun), inod, subtag
    call bort(bort_str)
  endif
  call nemtab(lun,subtag,isub,tab,iret)
  if(iret==0) then
    write(bort_str,'("BUFRLIB: MSGINI - TABLE A MESSAGE TYPE MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') subtag
    call bort(bort_str)
  endif
 
  ! Date can be YYMMDDHH or YYYYMMDDHH
 
  mcen = mod(idate(lun)/10**8,100)+1
  mear = mod(idate(lun)/10**6,100)
  mmon = mod(idate(lun)/10**4,100)
  mday = mod(idate(lun)/10**2,100)
  mour = mod(idate(lun)      ,100)
  mmin = 0
 
  if(mcen==1) call bort ('BUFRLIB: MSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000')
 
  if(mear==0) mcen = mcen-1
  if(mear==0) mear = 100
 
  ! Initialize the message
 
  mbit = 0
  nby0 = 8
  nby1 = 18
  nby2 = 0
  nby3 = 20
  nby4 = 4
  nby5 = 4
  nbyt = nby0+nby1+nby2+nby3+nby4+nby5
 
  ! Section 0
 
  call pkc(bufr ,  4 , mbay(1,lun),mbit)
  call pkb(nbyt , 24 , mbay(1,lun),mbit)
  call pkb(   3 ,  8 , mbay(1,lun),mbit)
 
  ! Section 1
 
  call pkb(nby1 , 24 , mbay(1,lun),mbit)
  call pkb(   0 ,  8 , mbay(1,lun),mbit)
  call pkb(   3 ,  8 , mbay(1,lun),mbit)
  call pkb(   7 ,  8 , mbay(1,lun),mbit)
  call pkb(   0 ,  8 , mbay(1,lun),mbit)
  call pkb(   0 ,  8 , mbay(1,lun),mbit)
  call pkb(mtyp ,  8 , mbay(1,lun),mbit)
  call pkb(msbt ,  8 , mbay(1,lun),mbit)
  call pkb(  36 ,  8 , mbay(1,lun),mbit)
  call pkb(   0 ,  8 , mbay(1,lun),mbit)
  call pkb(mear ,  8 , mbay(1,lun),mbit)
  call pkb(mmon ,  8 , mbay(1,lun),mbit)
  call pkb(mday ,  8 , mbay(1,lun),mbit)
  call pkb(mour ,  8 , mbay(1,lun),mbit)
  call pkb(mmin ,  8 , mbay(1,lun),mbit)
  call pkb(mcen ,  8 , mbay(1,lun),mbit)
 
  ! Section 3
 
  call pkb(nby3 , 24 , mbay(1,lun),mbit)
  call pkb(   0 ,  8 , mbay(1,lun),mbit)
  call pkb(   0 , 16 , mbay(1,lun),mbit)
  call pkb(2**7 ,  8 , mbay(1,lun),mbit)
  call pkb(ibct , 16 , mbay(1,lun),mbit)
  call pkb(isub , 16 , mbay(1,lun),mbit)
  call pkb(ipd1 , 16 , mbay(1,lun),mbit)
  call pkb(ipd2 , 16 , mbay(1,lun),mbit)
  call pkb(ipd3 , 16 , mbay(1,lun),mbit)
  call pkb(ipd4 , 16 , mbay(1,lun),mbit)
  call pkb(   0 ,  8 , mbay(1,lun),mbit)
 
  ! Section 4
 
  call pkb(nby4 , 24 , mbay(1,lun),mbit)
  call pkb(   0 ,  8 , mbay(1,lun),mbit)
 
  ! Section 5
 
  call pkc(sevn ,  4 , mbay(1,lun),mbit)
 
  ! Double check initial message length
 
  if(mod(mbit,8)/=0) call bort('BUFRLIB: MSGINI - INITIALIZED MESSAGE DOES NOT END ON A BYTE BOUNDARY')
  if(mbit/8/=nbyt) then
    write(bort_str,'("BUFRLIB: MSGINI - NUMBER OF BYTES STORED FOR INITIALIZED MESSAGE (",I6,") IS NOT THE SAME AS FIRST '// &
      'CALCULATED, NBYT (",I6)') mbit/8, nbyt
    call bort(bort_str)
  endif
 
  nmsg(lun) = nmsg(lun)+1
  nsub(lun) = 0
  mbyt(lun) = nbyt
 
  luncpy(lun)=0
 
  return
end subroutine msgini
 
logical function msgfull(msiz,itoadd,mxsiz) result(bool)
 
  use modv_vars, only: maxnc
 
  use moda_tnkrcp
  use moda_msgstd
 
  implicit none
 
  integer, intent(in) :: msiz, itoadd, mxsiz
  integer iwgbyt
 
  ! Allow for at least 11 additional bytes of "wiggle room" in the message, because subroutine msgwrt() may do any or all
  ! of the following:
  !      3 bytes may be added by a call to subroutine cnved4()
  !    + 1 byte (at most) of padding may be added to Section 4
  !    + 7 bytes (at most) of padding may be added up to the next word boundary after Section 5
  !   ----
  !     11
  iwgbyt = 11
 
  ! But subroutine msgwrt() may also do any of all of the following:
 
  ! 6 bytes may be added by a call to subroutine atrcpt()
  if(ctrt=='Y') iwgbyt = iwgbyt + 6
 
  ! (maxnc*2) bytes (at most) may be added by a call to subroutine stndrd()
  if(csmf=='Y') iwgbyt = iwgbyt + (maxnc*2)
 
  ! Determine whether the subset will fit.
 
  if ( ( msiz + itoadd + iwgbyt ) > mxsiz ) then
    bool = .true.
  else
    bool = .false.
  endif
 
  return
end function msgfull
 
recursive subroutine maxout(maxo)
 
  use modv_vars, only: mxmsgl, im8b
 
  use moda_bitbuf
 
  implicit none
 
  integer, intent(in) :: maxo
  integer my_maxo, iprt, newsiz, maxdx, idxv, nxstr, ldxa, ldxb, ldxd, ld30
 
  character*128 errstr
  character*56 dxstr
 
  common /dxtab/ maxdx,idxv,nxstr(10),ldxa(10),ldxb(10),ldxd(10),ld30(10),dxstr(10)
  common /quiet/ iprt
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(maxo,my_maxo,1)
    call maxout(my_maxo)
 
    im8b=.true.
    return
  endif
 
  if((maxo==0).or.(maxo>mxmsgl)) then
    newsiz = mxmsgl
  else
    newsiz = maxo
  endif
 
  if(iprt>=0) then
    if(maxbyt/=newsiz) then
      call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      write ( unit=errstr, fmt='(A,A,I7,A,I7)' ) 'BUFRLIB: MAXOUT - THE RECORD LENGTH OF ALL BUFR MESSAGES ',&
        'CREATED FROM THIS POINT ON IS BEING CHANGED FROM ', maxbyt, ' TO ', newsiz
      call errwrt(errstr)
      call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      call errwrt(' ')
    endif
  endif
 
  maxbyt = newsiz
  maxdx  = newsiz
 
  return
end subroutine maxout
 
integer function igetmxby() result(iret)
 
  use moda_bitbuf
 
  implicit none
 
  iret = maxbyt
 
  return
end function igetmxby
 
subroutine padmsg(mesg,lmesg,npbyt)
 
  use modv_vars, only: nbytw
 
  implicit none
 
  integer, intent(in) :: lmesg
  integer, intent(inout) :: mesg(*)
  integer, intent(out) :: npbyt
  integer nmw, nmb, ibit, i, nmwrd, iupbs01
 
  ! Make sure that the array is big enough to hold the additional byte padding that will be appended to the
  ! end of the message.
 
  nmw = nmwrd(mesg)
  if(nmw>lmesg) call bort('BUFRLIB: PADMSG - CANNOT ADD PADDING TO MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY')
 
  ! Pad from the end of the message up to the next 8-byte boundary.
 
  nmb = iupbs01(mesg,'LENM')
  ibit = nmb*8
  npbyt = ( nmw * nbytw ) - nmb
  do i = 1, npbyt
    call pkb(0,8,mesg,ibit)
  enddo
 
  return
end subroutine padmsg
 
recursive integer function nmsub(lunit) result(iret)
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
 
  implicit none
 
  integer, intent(in) :: lunit
  integer my_lunit, lun, il, im
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(lunit,my_lunit,1)
    iret=nmsub(my_lunit)
 
    im8b=.true.
    return
  endif
 
  iret = 0
 
  ! Check the file status
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: NMSUB - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
  if(il>0) call bort('BUFRLIB: NMSUB - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
  if(im==0) call bort('BUFRLIB: NMSUB - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
 
  iret = msub(lun)
 
  return
end function nmsub
 
integer function nmwrd(mbay) result(iret)
 
  use modv_vars, only: nbytw
 
  implicit none
 
  integer, intent(in) :: mbay(*)
  integer lenm, iupbs01
 
  lenm = iupbs01(mbay,'LENM')
  if(lenm==0) then
    iret = 0
  else
    iret = ((lenm/8)+1)*(8/nbytw)
  endif
 
  return
end function nmwrd
 
integer function lmsg(sec0) result(iret)
 
  implicit none
 
  integer msec0(2), nmwrd
 
  character*8, intent(in) :: sec0
  character*8 csec0
 
  equivalence(msec0,csec0)
 
  csec0 = sec0
  iret = nmwrd(msec0)
 
  return
end function lmsg
 
recursive subroutine getlens (mbay,ll,len0,len1,len2,len3,len4,len5)
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(in) :: mbay(*), ll
  integer, intent(out) :: len0, len1, len2, len3, len4, len5
  integer my_ll, iad2, iad3, iad4, iupbs01, iupb
 
  ! Check for I8 integers.
  if(im8b) then
    im8b=.false.
    call x84(ll,my_ll,1)
    call getlens(mbay,my_ll,len0,len1,len2,len3,len4,len5)
    call x48(len0,len0,1)
    call x48(len1,len1,1)
    call x48(len2,len2,1)
    call x48(len3,len3,1)
    call x48(len4,len4,1)
    call x48(len5,len5,1)
    im8b=.true.
    return
  endif
 
  len0 = -1
  len1 = -1
  len2 = -1
  len3 = -1
  len4 = -1
  len5 = -1
 
  if(ll<0) return
  len0 = iupbs01(mbay,'LEN0')
 
  if(ll<1) return
  len1 = iupbs01(mbay,'LEN1')
 
  if(ll<2) return
  iad2 = len0 + len1
  len2 = iupb(mbay,iad2+1,24) * iupbs01(mbay,'ISC2')
 
  if(ll<3) return
  iad3 = iad2 + len2
  len3 = iupb(mbay,iad3+1,24)
 
  if(ll<4) return
  iad4 = iad3 + len3
  len4 = iupb(mbay,iad4+1,24)
 
  if(ll<5) return
  len5 = 4
 
  return
end subroutine getlens
 
recursive subroutine cnved4(msgin,lmsgot,msgot)
 
  use modv_vars, only: im8b, nbytw
 
  implicit none
 
  integer, intent(in) :: msgin(*), lmsgot
  integer, intent(out) :: msgot(*)
  integer my_lmsgot, i, nmw, len0, len1, len2, len3, l4, l5, iad2, iad4, lenm, lenmot, len1ot, len3ot, ibit, iupbs01, nmwrd
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
    call x84 ( lmsgot, my_lmsgot, 1 )
    call cnved4 ( msgin, my_lmsgot*2, msgot )
    im8b=.true.
    return
  endif
 
  if(iupbs01(msgin,'BEN')==4) then
 
    ! The input message is already encoded using edition 4, so just copy it from msgin to msgot and then return.
 
    nmw = nmwrd(msgin)
    if(nmw>lmsgot) &
      call bort('BUFRLIB: CNVED4 - OVERFLOW OF OUTPUT (EDITION 4) MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY')
    do i = 1, nmw
      msgot(i) = msgin(i)
    enddo
    return
  endif
 
  ! Get some section lengths and addresses from the input message.
 
  call getlens(msgin,3,len0,len1,len2,len3,l4,l5)
 
  iad2 = len0 + len1
  iad4 = iad2 + len2 + len3
 
  lenm = iupbs01(msgin,'LENM')
 
  ! Check for overflow of the output array.  Note that the new edition 4 message will be a total of 3 bytes longer than the
  ! input message (i.e. 4 more bytes in Section 1, but 1 fewer byte in Section 3).
 
  lenmot = lenm + 3
  if(lenmot>(lmsgot*nbytw)) &
    call bort('BUFRLIB: CNVED4 - OVERFLOW OF OUTPUT (EDITION 4) MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY')
 
  len1ot = len1 + 4
  len3ot = len3 - 1
 
  ! Write Section 0 of the new message into the output array.
 
  call mvb ( msgin, 1, msgot, 1, 4 )
  ibit = 32
  call pkb ( lenmot, 24, msgot, ibit )
  call pkb ( 4, 8, msgot, ibit )
 
  ! Write Section 1 of the new message into the output array.
 
  call pkb ( len1ot, 24, msgot, ibit )
  call pkb ( iupbs01(msgin,'BMT'), 8, msgot, ibit )
  call pkb ( iupbs01(msgin,'OGCE'), 16, msgot, ibit )
  call pkb ( iupbs01(msgin,'GSES'), 16, msgot, ibit )
  call pkb ( iupbs01(msgin,'USN'), 8, msgot, ibit )
  call pkb ( iupbs01(msgin,'ISC2')*128, 8, msgot, ibit )
  call pkb ( iupbs01(msgin,'MTYP'), 8, msgot, ibit )
  ! Set a default of 255 for the international subcategory.
  call pkb ( 255, 8, msgot, ibit )
  call pkb ( iupbs01(msgin,'MSBT'), 8, msgot, ibit )
  call pkb ( iupbs01(msgin,'MTV'), 8, msgot, ibit )
  call pkb ( iupbs01(msgin,'MTVL'), 8, msgot, ibit )
  call pkb ( iupbs01(msgin,'YEAR'), 16, msgot, ibit )
  call pkb ( iupbs01(msgin,'MNTH'), 8, msgot, ibit )
  call pkb ( iupbs01(msgin,'DAYS'), 8, msgot, ibit )
  call pkb ( iupbs01(msgin,'HOUR'), 8, msgot, ibit )
  call pkb ( iupbs01(msgin,'MINU'), 8, msgot, ibit )
  ! Set a default of 0 for the second.
  call pkb ( 0, 8, msgot, ibit )
 
  ! Copy Section 2 (if it exists) through the next-to-last byte of Section 3 from the input array to the output array.
 
  call mvb ( msgin, iad2+1, msgot, (ibit/8)+1, len2+len3-1 )
 
  ! Store the length of the new Section 3.
 
  ibit = ( len0 + len1ot + len2 ) * 8
  call pkb ( len3ot, 24, msgot, ibit )
 
  ! Copy Section 4 and Section 5 from the input array to the output array.
 
  ibit = ibit + ( len3ot * 8 ) - 24
  call mvb ( msgin, iad4+1, msgot, (ibit/8)+1, lenm-iad4 )
 
  return
end subroutine cnved4
 
recursive integer function ifbget(lunit) result(iret)
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
 
  implicit none
 
  integer, intent(in) :: lunit
  integer my_lunit, lun, il, im
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    iret=ifbget(my_lunit)
    im8b=.true.
    return
  endif
 
  iret = -1
 
  ! Make sure a file/message is open for input
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: IFBGET - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
  if(il>0) call bort('BUFRLIB: IFBGET - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
  if(im==0) call bort('BUFRLIB: IFBGET - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
 
  ! Check if there's another subset in the message
 
  if(nsub(lun)<msub(lun)) iret = 0
 
  return
end function ifbget