s013vals.F90

Go to the documentation of this file.

 
 
recursive subroutine gets1loc(s1mnem,iben,isbyt,iwid,iret)
 
  use modv_vars, only: im8b
 
  implicit none
 
  character*(*), intent(in) :: s1mnem
 
  integer, intent(in) :: iben
  integer, intent(out) :: isbyt, iwid, iret
  integer my_iben
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
 
    call x84(iben,my_iben,1)
    call gets1loc(s1mnem,my_iben,isbyt,iwid,iret)
    call x48(isbyt,isbyt,1)
    call x48(iwid,iwid,1)
    call x48(iret,iret,1)
 
    im8b=.true.
    return
  endif
 
  iret = 0
  iwid = 8
 
  if(s1mnem=='LEN1') then
    isbyt = 1
    iwid = 24
  else if(s1mnem=='BMT') then
    isbyt = 4
  else if(s1mnem=='OGCE') then
    if(iben==3) then
      isbyt = 6
    else
      ! Note that this location is actually the same for both edition 2 and edition 4 of BUFR
      isbyt = 5
      iwid = 16
    endif
  else if(s1mnem=='GSES') then
    if(iben==3) then
      isbyt = 5
    else if(iben==4) then
      isbyt = 7
      iwid = 16
    else
      iret = -1
    endif
  else if(s1mnem=='USN') then
    if(iben==4) then
      isbyt = 9
    else
      isbyt = 7
    endif
  else if(s1mnem=='ISC2') then
    iwid = 1
    if(iben==4) then
      isbyt = 10
    else
      isbyt = 8
    endif
  else if(s1mnem=='MTYP') then
    if(iben==4) then
      isbyt = 11
    else
      isbyt = 9
    endif
  else if(s1mnem=='MSBTI') then
    if(iben==4) then
      isbyt = 12
    else
      iret = -1
    endif
  else if(s1mnem=='MSBT') then
    if(iben==4) then
      isbyt = 13
    else
      isbyt = 10
    endif
  else if(s1mnem=='MTV') then
    if(iben==4) then
      isbyt = 14
    else
      isbyt = 11
    endif
  else if(s1mnem=='MTVL') then
    if(iben==4) then
      isbyt = 15
    else
      isbyt = 12
    endif
  else if(s1mnem=='YEAR') then
    if(iben==4) then
      isbyt = 16
      iwid = 16
    else
      iret = -1
    endif
  else if(s1mnem=='YCEN') then
    if(iben<4) then
      isbyt = 13
    else
      iret = -1
    endif
  else if(s1mnem=='CENT') then
    if(iben<4) then
      isbyt = 18
    else
      iret = -1
    endif
  else if(s1mnem=='MNTH') then
    if(iben==4) then
      isbyt = 18
    else
      isbyt = 14
    endif
  else if(s1mnem=='DAYS') then
    if(iben==4) then
      isbyt = 19
    else
      isbyt = 15
    endif
  else if(s1mnem=='HOUR') then
    if(iben==4) then
      isbyt = 20
    else
      isbyt = 16
    endif
  else if(s1mnem=='MINU') then
    if(iben==4) then
      isbyt = 21
    else
      isbyt = 17
    endif
  else if(s1mnem=='SECO') then
    if(iben==4) then
      isbyt = 22
    else
      iret = -1
    endif
  else
    iret = -1
  endif
 
  return
end subroutine gets1loc
 
recursive integer function iupbs01(mbay,s01mnem) result(iret)
 
  use modv_vars, only: im8b
 
  implicit none
 
  character*(*), intent(in) :: s01mnem
 
  integer, intent(in) :: mbay(*)
  integer ival, iupb, i4dy, len0, iben, isbyt, iwid, iretgs, iyoc, icen
 
  logical ok4cent
 
  ! This statement function checks whether its input value contains a valid century value.
  ok4cent(ival) = ((ival>=19).and.(ival<=21))
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
 
    iret = iupbs01(mbay,s01mnem)
 
    im8b=.true.
    return
  endif
 
  ! Handle some simple requests that do not depend on the BUFR edition number.
 
  if(s01mnem=='LENM') then
    iret = iupb(mbay,5,24)
    return
  endif
 
  len0 = 8
  if(s01mnem=='LEN0') then
    iret = len0
    return
  endif
 
  ! Get the BUFR edition number.
 
  iben = iupb(mbay,8,8)
  if(s01mnem=='BEN') then
    iret = iben
    return
  endif
 
  ! Use the BUFR edition number to handle any other requests.
 
  call gets1loc(s01mnem,iben,isbyt,iwid,iretgs)
  if(iretgs==0) then
    iret = iupb(mbay,len0+isbyt,iwid)
    if(s01mnem=='CENT') then
 
      ! Test whether the returned value was a valid century value.
 
      if(.not.ok4cent(iret)) iret = -1
    endif
  else if( (s01mnem=='YEAR') .and. (iben<4) ) then
 
    ! Calculate the 4-digit year.
 
    iyoc = iupb(mbay,21,8)
    icen = iupb(mbay,26,8)
 
    ! Does icen contain a valid century value?
 
    if(ok4cent(icen)) then
      ! YES, so use it to calculate the 4-digit year. Note that, by international convention, the year 2000 was the 100th
      ! year of the 20th century, and the year 2001 was the 1st year of the 21st century
      iret = (icen-1)*100 + iyoc
    else
      ! NO, so use a windowing technique to determine the 4-digit year from the year of the century.
      iret = i4dy(mod(iyoc,100)*1000000)/10**6
    endif
  else
    iret = -1
  endif
 
  return
end function iupbs01
 
recursive integer function iupbs3(mbay,s3mnem) result(iret)
 
  use modv_vars, only: im8b
 
  implicit none
 
  character*(*), intent(in) :: s3mnem
 
  integer, intent(in) :: mbay(*)
  integer len0, len1, len2, len3, l4, l5, ipt, ival, imask, iupb
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
 
    iret = iupbs3(mbay,s3mnem)
 
    im8b=.true.
    return
  endif
 
  ! Skip to the beginning of Section 3.
 
  call getlens(mbay,3,len0,len1,len2,len3,l4,l5)
  ipt = len0 + len1 + len2
 
  ! Unpack the requested value.
 
  if(s3mnem=='NSUB') then
    iret = iupb(mbay,ipt+5,16)
  else if( (s3mnem=='IOBS') .or. (s3mnem=='ICMP') ) then
    ival = iupb(mbay,ipt+7,8)
    if(s3mnem=='IOBS') then
      imask = 128
    else
      imask = 64
    endif
    iret = min(1,iand(ival,imask))
  else
    iret = -1
  endif
 
  return
end function iupbs3
 
recursive integer function iupvs01(lunit,s01mnem) result(iret)
 
  use modv_vars, only: im8b
 
  use moda_bitbuf
 
  implicit none
 
  character*(*), intent(in) :: s01mnem
 
  integer, intent(in) :: lunit
  integer my_lunit, lun, ilst, imst, iupbs01
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(lunit,my_lunit,1)
    iret=iupvs01(my_lunit,s01mnem)
 
    im8b=.true.
    return
  endif
 
  iret = -1
 
  ! Check the file status
 
  call status(lunit,lun,ilst,imst)
  if(ilst==0) call bort('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
  if(ilst>0) call bort('BUFRLIB: IUPVS01 - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
  if(imst==0) call bort('BUFRLIB: IUPVS01 - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
 
  ! Unpack the requested value
 
  iret = iupbs01(mbay(1,lun),s01mnem)
 
  return
end function iupvs01
 
recursive subroutine pkbs1(ival,mbay,s1mnem)
 
  use modv_vars, only: im8b
 
  implicit none
 
  character*(*), intent(in) :: s1mnem
 
  integer, intent(in) :: ival
  integer, intent(inout) :: mbay(*)
  integer my_ival, iben, isbyt, iwid, iret, iupbs01, ibit
 
  character*128 bort_str
 
  ! Check for I8 integers.
 
  if (im8b) then
    im8b = .false.
 
    call x84(ival,my_ival,1)
    call pkbs1(my_ival,mbay,s1mnem)
 
    im8b = .true.
    return
  end if
 
  iben = iupbs01(mbay,'BEN')
 
  ! Determine where to store the value.
 
  call gets1loc(s1mnem,iben,isbyt,iwid,iret)
  if ( (iret==0) .and. &
      ( (s1mnem=='USN') .or. (s1mnem=='BMT') .or. (s1mnem=='OGCE') .or. (s1mnem=='GSES') .or. (s1mnem=='MTYP') .or. &
       (s1mnem=='MSBTI') .or. (s1mnem=='MSBT') .or. (s1mnem=='MTV') .or. (s1mnem=='MTVL') .or. (s1mnem=='YCEN') .or.&
       (s1mnem=='CENT') .or. (s1mnem=='YEAR') .or. (s1mnem=='MNTH') .or. (s1mnem=='DAYS') .or. (s1mnem=='HOUR') .or.&
       (s1mnem=='MINU') .or. (s1mnem=='SECO') ) ) then
    ! Store the value.
    ibit = (iupbs01(mbay,'LEN0')+isbyt-1)*8
    call pkb(ival,iwid,mbay,ibit)
  else
    write(bort_str,'("BUFRLIB: PKBS1 - CANNOT OVERWRITE LOCATION CORRESPONDING TO MNEMONIC (",A,") WITHIN BUFR EDITION '// &
      '(",I1,")")') s1mnem, iben
    call bort(bort_str)
  endif
 
  return
end subroutine pkbs1
 
recursive subroutine pkvs01(s01mnem,ival)
 
  use modv_vars, only: im8b, mxs01v
 
  use moda_s01cm
 
  implicit none
 
  character*(*), intent(in) :: s01mnem
 
  integer, intent(in) :: ival
  integer my_ival, i
 
  character*128 bort_str
 
  ! check for i8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(ival,my_ival,1)
    call pkvs01(s01mnem,my_ival)
 
    im8b=.true.
    return
  endif
 
  ! Confirm that the arrays needed by this subroutine have already been allocated (and if not, go ahead and allocate them now),
  ! since it's possible for this subroutine to be called before the first call to subroutine openbf().
 
  if ( ( .not. allocated(cmnem) ) .or. ( .not. allocated(ivmnem) ) ) then
    call openbf(0,'FIRST',0)
  endif
 
  ! If an ival has already been assigned for this particular s01mnem, then overwrite that entry in module @ref moda_s01cm
  ! using the new ival.
 
  if(ns01v>0) then
    do i=1,ns01v
      if(s01mnem==cmnem(i)) then
        ivmnem(i) = ival
        return
      endif
    enddo
  endif
 
  ! Otherwise, use the next available unused entry in module @ref moda_s01cm.
 
  if(ns01v>=mxs01v) then
    write(bort_str,'("BUFRLIB: PKVS01 - CANNOT OVERWRITE MORE THAN ",I2," DIFFERENT LOCATIONS WITHIN SECTION 0 '// &
      'OR SECTION 1")') mxs01v
    call bort(bort_str)
  endif
 
  ns01v = ns01v + 1
  cmnem(ns01v) = s01mnem
  ivmnem(ns01v) = ival
 
  return
end subroutine pkvs01
 
subroutine reads3 ( lun )
 
  use bufrlib
 
  use modv_vars, only: maxnc, mxcnem
 
  use moda_sc3bfr
  use moda_bitbuf
  use moda_dscach
  use moda_s3list
 
  implicit none
 
  integer, intent(in) :: lun
  integer iprt, irepct, ireadmt, igettdi, itmp, ncds3, ii, jj, ifxy, igetntbi, n, idn
 
  character*6 numb, adn30
  character*55 cseq
  character*128 errstr
 
  logical incach
 
  common /quiet/ iprt
 
  save irepct
 
  ! Check whether the appropriate BUFR master table information has already been read into internal memory for this message.
 
  if ( ireadmt( lun ) == 1 ) then
    ! NO (i.e. we just had to read in new master table information for this message), so reset some corresponding values in
    ! other parts of the library.
    call dxinit ( lun, 0 )
    itmp = igettdi( 0 )
    irepct = 0
    ncnem = 0
  endif
 
  ! Unpack the list of Section 3 descriptors from the message.
 
  call upds3 ( mbay(1,lun), maxnc, cds3, ncds3 )
  do ii = 1, ncds3
    ids3(ii) = ifxy( cds3(ii) )
  enddo
 
  ! Is the list of Section 3 descriptors already in the cache?
 
  ! The cache is a performance-enhancing device which saves time when the same descriptor sequences are encountered over and
  ! over within the calling program.  Time is saved because the below calls to subroutines stseq_c() and makestab() are
  ! bypassed whenever a list is already in the cache.
 
  incach = .false.
  if ( ncnem > 0 ) then
    ii = 1
    do while ( (.not.incach) .and. (ii<=ncnem) )
      if ( ncds3 == ndc(ii) ) then
        jj = 1
        incach = .true.
        do while ( (incach) .and. (jj<=ncds3) )
          if ( ids3(jj) == idcach(ii,jj) ) then
            jj = jj + 1
          else
            incach = .false.
          endif
        enddo
        if (incach) then
 
          ! The list is already in the cache, so store the corresponding Table A mnemonic into module @ref moda_sc3bfr and return.
 
          if ( iprt >= 2 ) then
            call errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++')
            errstr = 'BUFRLIB: READS3 - RE-USED CACHE LIST FOR ' // cnem(ii)
            call errwrt(errstr)
            call errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++')
            call errwrt(' ')
          endif
          tamnem(lun) = cnem(ii)
          return
        endif
      endif
      ii = ii + 1
    enddo
  endif
 
  ! Get the next available index within the internal Table A.
 
  n = igetntbi( lun, 'A' )
 
  ! Generate a Table A mnemonic and sequence description.
 
  write ( tamnem(lun), '(A5,I3.3)') 'MSTTB', n
  cseq = 'TABLE A MNEMONIC ' // tamnem(lun)
 
  ! Store the Table A mnemonic and sequence into the cache.
 
  ncnem = ncnem + 1
  if ( ncnem > mxcnem ) call bort('BUFRLIB: READS3 - MXCNEM OVERFLOW')
  cnem(ncnem) = tamnem(lun)
  ndc(ncnem) = ncds3
  do jj = 1, ncds3
    idcach(ncnem,jj) = ids3(jj)
  enddo
  if ( iprt >= 2 ) then
    call errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++')
    errstr = 'BUFRLIB: READS3 - STORED CACHE LIST FOR ' // cnem(ncnem)
    call errwrt(errstr)
    call errwrt('+++++++++++++++++++++++++++++++++++++++++++++++++')
    call errwrt(' ')
  endif
 
  ! Get an FXY value to use with this Table A mnemonic.
 
  idn = igettdi( lun )
  numb = adn30( idn, 6 )
 
  ! Store all of the information for this mnemonic within the internal Table A.
 
  call stntbia ( n, lun, numb, tamnem(lun), cseq )
 
  ! Store all of the information for this sequence within the internal Tables B and D.
 
  call stseq_c ( lun, irepct, idn, tamnem(lun), cseq, ids3, ncds3 )
 
  ! Update the jump/link table.
 
  call makestab
 
  return
end subroutine reads3
 
recursive subroutine upds3(mbay,lcds3,cds3,nds3)
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(in) :: mbay(*), lcds3
  integer, intent(out) :: nds3
  integer my_lcds3, len0, len1, len2, len3, l4, l5, ipt, jj, iupb
 
  character*6, intent(out) :: cds3(*)
  character*6 adn30
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
 
    call x84(lcds3,my_lcds3,1)
    call upds3(mbay,my_lcds3,cds3,nds3)
    call x48(nds3,nds3,1)
 
    im8b=.true.
    return
  endif
 
  ! Skip to the beginning of Section 3.
 
  call getlens(mbay,3,len0,len1,len2,len3,l4,l5)
  ipt = len0 + len1 + len2
 
  ! Unpack the Section 3 descriptors.
 
  nds3 = 0
  do jj = 8,(len3-1),2
   nds3 = nds3 + 1
   if(nds3>lcds3) call bort('BUFRLIB: UPDS3 - OVERFLOW OF OUTPUT DESCRIPTOR ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY')
   cds3(nds3) = adn30(iupb(mbay,ipt+jj,16),6)
  enddo
 
  return
end subroutine upds3
 
recursive subroutine datelen(len)
 
  use modv_vars, only: im8b, lendat
 
  implicit none
 
  integer, intent(in) :: len
  integer my_len
 
  character*128 bort_str
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(len,my_len,1)
    call datelen(my_len)
 
    im8b=.true.
    return
  endif
 
  if(len/=8 .and. len/=10) then
    write(bort_str,'("BUFRLIB: DATELEN - INPUT ARGUMENT IS",I4," - IT MUST BE EITHER 8 OR 10")') len
    call bort(bort_str)
  endif
  lendat = len
 
  return
end subroutine datelen
 
recursive subroutine datebf(lunit,mear,mmon,mday,mour,idate)
 
  use modv_vars, only: im8b
 
  use moda_mgwa
 
  implicit none
 
  integer, intent(in) :: lunit
  integer, intent(out) :: mear, mmon, mday, mour, idate
  integer my_lunit, iprt, lun, jl, jm, ier, idx, idxmsg, igetdate
 
  character*128 errstr
 
  common /quiet/ iprt
 
  !  Check for I8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(lunit,my_lunit,1)
    call datebf(my_lunit,mear,mmon,mday,mour,idate)
    call x48(mear,mear,1)
    call x48(mmon,mmon,1)
    call x48(mday,mday,1)
    call x48(mour,mour,1)
    call x48(idate,idate,1)
 
    im8b=.true.
    return
  endif
 
  ! Initialization, in case openbf() hasn't been called yet.
 
  if ( .not. allocated(mgwa) ) call openbf(lunit,'FIRST',lunit)
 
  ! See if the file is already open to the library (a no-no!).
 
  call status(lunit,lun,jl,jm)
  if(jl/=0) call bort ('BUFRLIB: DATEBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED')
 
  ! Read to the first data message and pick out the date.
 
  call openbf(lunit,'INX',lunit)
  idx = 1
  do while (idx==1)
    call rdmsgw(lunit,mgwa,ier)
    if(ier<0) then
      if (iprt>=1) then
        call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
        errstr = 'BUFRLIB: DATEBF - SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH IDATE = -1'
        call errwrt(errstr)
        call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
        call errwrt(' ')
      endif
      idate = -1
      call closbf(lunit)
      return
    endif
    idx = idxmsg(mgwa)
  end do
  idate = igetdate(mgwa,mear,mmon,mday,mour)
  call closbf(lunit)
 
  return
end subroutine datebf
 
recursive integer function igetdate(mbay,iyr,imo,idy,ihr) result(iret)
 
  use modv_vars, only: im8b, lendat
 
  implicit none
 
  integer, intent(in) :: mbay(*)
  integer, intent(out) :: iyr, imo, idy, ihr
  integer iupbs01
 
  ! Check for I8 integers.
 
  if(im8b) then
     im8b=.false.
 
     iret=igetdate(mbay,iyr,imo,idy,ihr)
     call x48(iyr,iyr,1)
     call x48(imo,imo,1)
     call x48(idy,idy,1)
     call x48(ihr,ihr,1)
 
     im8b=.true.
     return
  endif
 
  iyr = iupbs01(mbay,'YEAR')
  imo = iupbs01(mbay,'MNTH')
  idy = iupbs01(mbay,'DAYS')
  ihr = iupbs01(mbay,'HOUR')
  if(lendat/=10) iyr = mod(iyr,100)
  iret = (iyr*1000000) + (imo*10000) + (idy*100) + ihr
 
  return
end function igetdate
 
recursive integer function i4dy(idate) result(iret)
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(in) :: idate
  integer my_idate, iy
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
 
    call x84(idate,my_idate,1)
    iret=i4dy(my_idate)
 
    im8b=.true.
    return
  endif
 
  if(idate<10**8) then
    iy = idate/10**6
    if(iy>40) then
       iret = idate + 19*100000000
    else
       iret = idate + 20*100000000
    endif
  else
    iret = idate
  endif
 
  return
end function i4dy
 
recursive subroutine dumpbf(lunit,jdate,jdump)
 
  use modv_vars, only: im8b
 
  use moda_mgwa
 
  implicit none
 
  integer, intent(in) :: lunit
  integer, intent(out) :: jdate(*), jdump(*)
  integer my_lunit, lun, jl, jm, iprt, ier, ii, igetdate, idxmsg, iupbs3, iupbs01
 
  character*128 errstr
 
  common /quiet/ iprt
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
 
    call x84(lunit,my_lunit,1)
    call dumpbf(my_lunit,jdate,jdump)
    call x48(jdate(1),jdate(1),5)
    call x48(jdump(1),jdump(1),5)
 
    im8b=.true.
    return
  endif
 
  do ii=1,5
    jdate(ii) = -1
    jdump(ii) = -1
  enddo
 
  ! See if the file is already open to the library (a no-no!).
 
  call status(lunit,lun,jl,jm)
  if(jl/=0) call bort('BUFRLIB: DUMPBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED')
  call openbf(lunit,'INX',lunit)
 
  do while (.true.)
    call rdmsgw(lunit,mgwa,ier)
    if(ier/=0) exit
    if(idxmsg(mgwa)==1) cycle   ! Skip past any dictionary messages
 
    ! The dump center YY,MM,DD,HH,MM should be in this message, which is the first message containing zero subsets
    if(iupbs3(mgwa,'NSUB')/=0) exit
    ii = igetdate(mgwa,jdate(1),jdate(2),jdate(3),jdate(4))
    jdate(5) = iupbs01(mgwa,'MINU')
 
    ! The dump clock YY,MM,DD,HH,MM should be in the next message, which is the second message containing zero subsets
    call rdmsgw(lunit,mgwa,ier)
    if(ier/=0) exit
    if(iupbs3(mgwa,'NSUB')/=0) exit
    ii = igetdate(mgwa,jdump(1),jdump(2),jdump(3),jdump(4))
    jdump(5) = iupbs01(mgwa,'MINU')
 
    call closbf(lunit)
    return
  enddo
 
  if (iprt>=1 .and. (jdate(1)==-1.or.jdump(1)==-1)) then
    call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
    if(jdate(1)==-1) then
      errstr = 'BUFRLIB: DUMPBF - FIRST  EMPTY BUFR MESSAGE SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH JDATE = 5*-1'
      call errwrt(errstr)
    endif
    if(jdump(1)==-1) then
      errstr = 'BUFRLIB: DUMPBF - SECOND EMPTY BUFR MESSAGE SECTION 1 DATE COULD NOT BE LOCATED - RETURN WITH JDUMP = 5*-1'
      call errwrt(errstr)
    endif
    call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
    call errwrt(' ')
  endif
 
  return
end subroutine dumpbf
 
recursive subroutine minimg(lunit,mini)
 
  use modv_vars, only: im8b
 
  use moda_bitbuf
 
  implicit none
 
  integer, intent(in) :: lunit, mini
  integer my_lunit, my_mini, lun, il, im
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
 
    call x84(lunit,my_lunit,1)
    call x84(mini,my_mini,1)
    call minimg(my_lunit,my_mini)
 
    im8b=.true.
    return
  endif
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
  if(il<0) call bort('BUFRLIB: MINIMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
  if(im==0) call bort('BUFRLIB: MINIMG - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
 
  call pkbs1(mini,mbay(1,lun),'MINU')
 
  return
end subroutine minimg
 
subroutine cktaba(lun,subset,jdate,iret)
 
  use moda_msgcwd
  use moda_sc3bfr
  use moda_unptyp
  use moda_bitbuf
 
  implicit none
 
  integer, intent(in) :: lun
  integer, intent(out) :: jdate, iret
  integer, parameter :: ncpfx = 3
  integer ibct, ipd1, ipd2, ipd3, ipd4, iprt, mtyp, msbt, mty1, msb1, isub, ksub, len0, len1, len2, len3, l4, l5, lundx, ii, &
    itab, inod, iad3, iad4, iyr, imo, idy, ihr, iupb, iupbs01, iupbs3, i4dy, igetdate
 
  character*128 bort_str, errstr
  character*8, intent(out) :: subset
  character*2, parameter :: cpfx(ncpfx) = (/'NC','FR','FN'/)
  character tab
 
  logical trybt
 
  common /padesc/ ibct, ipd1, ipd2, ipd3, ipd4
  common /quiet/ iprt
 
  iret = 0
 
  trybt = .true.
 
  ! Get the message type, subtype, and date from Section 1
 
  mtyp = iupbs01(mbay(1,lun),'MTYP')
  msbt = iupbs01(mbay(1,lun),'MSBT')
  jdate = igetdate(mbay(1,lun),iyr,imo,idy,ihr)
 
  if(mtyp==11) then
    ! This is a BUFR table (dictionary) message
    iret = 11
    ! There's no need to proceed any further unless Section 3 is being used for decoding
    if(isc3(lun)==0) then
      subset = "        "
      return
    endif
  endif
 
  ! Get the first and second descriptors from Section 3
 
  call getlens(mbay(1,lun),3,len0,len1,len2,len3,l4,l5)
  iad3 = len0+len1+len2
  ksub = iupb(mbay(1,lun),iad3+8,16)
  isub = iupb(mbay(1,lun),iad3+10,16)
 
  ! Locate Section 4
 
  iad4 = iad3+len3
 
  ! Now, try to get the Table A mnemonic
 
  outer: do while (.true.)
 
    if(isc3(lun)/=0) then
      ! Section 3 is being used for decoding
      subset = tamnem(lun)
      call nemtbax(lun,subset,mty1,msb1,inod)
      if(inod>0) then
        mbyt(lun) = 8*(iad4+4)
        msgunp(lun) = 1
        exit outer
      endif
    endif
 
    inner: do while (.true.)
 
      call numtab(lun,isub,subset,tab,itab)
      call nemtbax(lun,subset,mty1,msb1,inod)
      if(inod>0) then
        ! The second descriptor in Section 3 corresponds to the Table A mnemonic, so the message contains non-standard
        ! NCEP extensions
        mbyt(lun) = (iad4+4)
        msgunp(lun) = 0
        exit outer
      endif
 
      call numtab(lun,ksub,subset,tab,itab)
      call nemtbax(lun,subset,mty1,msb1,inod)
      if(inod>0) then
        ! The first descriptor in Section 3 corresponds to the Table A mnemonic, so the message is WMO-standard
        mbyt(lun) = 8*(iad4+4)
        msgunp(lun) = 1
        exit outer
      endif
 
      ! OK, still no luck, so try "NCtttsss" (where ttt=mtyp and sss=msbt) as the Table A mnemonic, and if that doesn't work
      ! then also try "FRtttsss" AND "FNtttsss"
      ii=1
      do while(ii<=ncpfx)
        write(subset,'(A2,2I3.3)') cpfx(ii),mtyp,msbt
        call nemtbax(lun,subset,mty1,msb1,inod)
        if(inod>0) then
          if(ksub==ibct) then
            mbyt(lun) = (iad4+4)
            msgunp(lun) = 0
          else
            mbyt(lun) = 8*(iad4+4)
            msgunp(lun) = 1
          endif
          exit outer
        endif
        ii=ii+1
      enddo
 
      if(trybt) then
        ! Make one last desperate attempt by checking whether the application program contains an in-line version of
        ! subroutine openbt() to override the default version in the library
        trybt = .false.
        if(iprt>=1) then
          call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
          errstr = 'BUFRLIB: CKTABA - LAST RESORT, CHECK FOR EXTERNAL BUFR TABLE VIA CALL TO IN-LINE OPENBT'
          call errwrt(errstr)
          call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
          call errwrt(' ')
        endif
        call openbt(lundx,mtyp)
        if(lundx>0) then
          ! There was an in-line replacement for the default library version of openbt(), so read DX table information from
          ! the specified logical unit and look for the Table A mnemonic there
          call rdusdx(lundx,lun)
          cycle inner
        endif
      endif
 
      ! Give up and report the bad news
      if(iprt>=0) then
        call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
        errstr = 'BUFRLIB: CKTABA - UNRECOGNIZED TABLE A MESSAGE TYPE (' // subset // ') - RETURN WITH IRET = -1'
        call errwrt(errstr)
        call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
        call errwrt(' ')
      endif
      iret = -1
      return
 
    enddo inner
 
  enddo outer
 
  ! Confirm the validity of the message type and subtype, and also check for compression
 
  if(isc3(lun)==0) then
    if(mtyp/=mty1) then
      write(bort_str,'("BUFRLIB: CKTABA - MESSAGE TYPE MISMATCH (SUBSET=",A8,", MTYP=",I3,", MTY1=",I3)') subset,mtyp,mty1
      call bort(bort_str)
    endif
    if( msbt/=msb1 .and. ( verify(subset(3:8),'1234567890') == 0 ) ) then
      write(bort_str,'("BUFRLIB: CKTABA - MESSAGE SUBTYPE MISMATCH (SUBSET=",A8,", MSBT=",I3,", MSB1=",I3)') subset,msbt,msb1
      call bort(bort_str)
    endif
  endif
  if(iupbs3(mbay(1,lun),'ICMP')>0) msgunp(lun) = 2
 
  ! Update values in @ref moda_msgcwd
 
  idate(lun) = i4dy(jdate)
  inode(lun) = inod
  msub(lun) = iupbs3(mbay(1,lun),'NSUB')
  nsub(lun) = 0
  if(iret/=11) nmsg(lun) = nmsg(lun)+1
 
  return
end subroutine cktaba
 
recursive subroutine mesgbc(lunin,mesgtyp,icomp)
 
  use modv_vars, only: im8b
 
  use moda_bitbuf
  use moda_mgwa
 
  implicit none
 
  integer, intent(in) :: lunin
  integer, intent(out) :: mesgtyp, icomp
  integer my_lunin, lunit, irec, ier, i, lun, il, im, iupbs01, iupbs3, idxmsg
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunin,my_lunin,1)
    call mesgbc(my_lunin,mesgtyp,icomp)
    call x48(mesgtyp,mesgtyp,1)
    call x48(icomp,icomp,1)
    im8b=.true.
    return
  endif
 
  mesgtyp = -256
 
  lunit = abs(lunin)
 
  if(lunit==lunin) then
    ! Open the file, read past any DX BUFR tables and "dummy" messages, and return the first message type found
    irec = 0
    call openbf(lunit,'INX',lunit)
    do while (.true.)
      call rdmsgw(lunit,mgwa,ier)
      if(ier==-1) then
        if(irec==0) then
          mesgtyp = -256
          icomp = -3
        else
          if(mesgtyp>=0) mesgtyp = -mesgtyp
          icomp = -2
        endif
        call closbf(lunit)
        return
      endif
      irec = irec + 1
      mesgtyp = iupbs01(mgwa,'MTYP')
      if( (idxmsg(mgwa)/=1) .and. (iupbs3(mgwa,'NSUB')/=0) ) exit
    enddo
    call closbf(lunit)
  else
    ! Return message type for message currently stored in memory
    call status(lunit,lun,il,im)
    do i=1,12
      mgwa(i) = mbay(i,lun)
    enddo
    mesgtyp = iupbs01(mgwa,'MTYP')
  end if
 
  ! Set the compression switch
  icomp = iupbs3(mgwa,'ICMP')
 
  return
end subroutine mesgbc
 
recursive subroutine mesgbf(lunit,mesgtyp)
 
  use modv_vars, only: im8b
 
  use moda_mgwa
 
  implicit none
 
  integer, intent(in) :: lunit
  integer, intent(out) :: mesgtyp
  integer my_lunit, ier, iupbs01, idxmsg
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call mesgbf(my_lunit,mesgtyp)
    call x48(mesgtyp,mesgtyp,1)
    im8b=.true.
    return
  endif
 
  mesgtyp = -1
 
  call openbf(lunit,'INX',lunit)
 
  do while (.true.)
    call rdmsgw(lunit,mgwa,ier)
    if(ier==0) then
      mesgtyp = iupbs01(mgwa,'MTYP')
      if(idxmsg(mgwa)/=1) exit
    endif
  enddo
 
  call closbf(lunit)
 
  return
end subroutine mesgbf