openclosebf.F90

Go to the documentation of this file.

 
 
recursive subroutine fortran_open(filename, lunit, format, position, iret)
 
  use modv_vars, only: im8b
 
  implicit none
  character*(*), intent(in) :: filename, format, position
  integer, intent(in)  :: lunit
  integer, intent(out) :: iret
  integer my_lunit
 
  ! check for i8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call fortran_open(filename,my_lunit,format,position,iret)
    call x48(iret,iret,1)
    im8b=.true.
    return
  endif
 
  open(lunit, file=trim(filename), form=trim(format), position=trim(position), iostat=iret)
  return
end subroutine fortran_open
 
recursive subroutine fortran_close(lunit, iret)
 
  use modv_vars, only: im8b
 
  implicit none
  integer, intent(in)  :: lunit
  integer, intent(out) :: iret
  integer my_lunit
 
  ! check for i8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call fortran_close(my_lunit,iret)
    call x48(iret,iret,1)
    im8b=.true.
    return
  endif
 
  close(lunit, iostat=iret)
  return
end subroutine fortran_close
 
recursive subroutine openbf(lunit,io,lundx)
 
  use bufrlib
 
  use modv_vars, only: im8b, ifopbf, nfiles, iprt
 
  use moda_msgcwd
  use moda_stbfr
  use moda_sc3bfr
  use moda_lushr
  use moda_nulbfr
  use moda_stcode
 
  implicit none
 
  integer, intent(in) :: lunit, lundx
  integer my_lunit, my_lundx, iprtprv, lun, il, im, lcio, bort_target_set
 
  character*(*), intent(in) :: io
  character*255 filename, fileacc
  character*128 bort_str, errstr
  character*28 cprint(0:4)
  character*6 cio
 
  data cprint/ &
    ' (only aborts)              ', &
    ' (limited -default)         ', &
    ' (all warnings)             ', &
    ' (all warnings+infos)       ', &
    ' (all warnings+infos+debugs)'/
 
  ! Check for i8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call x84(lundx,my_lundx,1)
    call openbf(my_lunit,io,my_lundx)
    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(io,cio,lcio)
    call catch_bort_openbf_c(lunit,cio,lundx,lcio)
    call bort_target_unset
    return
  endif
 
  if(io=='QUIET') then
    ! Override previous iprt value
    iprtprv = iprt
    iprt = lundx
    if(iprt<-1) iprt = -1
    if(iprt>3) iprt =  3
    if(iprt>=0) then
      call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      write ( unit=errstr, fmt='(A,I3,A,A,I3,A)' ) 'BUFRLIB: OPENBF - DEGREE OF MESSAGE PRINT INDICATOR CHNGED FROM', &
        iprtprv,cprint(iprtprv+1),' TO',iprt,cprint(iprt+1)
      call errwrt(errstr)
      call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
      call errwrt(' ')
    endif
  endif
 
  if(ifopbf==0) then
    ! This is the first call to this subroutine, so take care of some initial housekeeping tasks.
    ! Note that arallocf and arallocc_c must be called before calling bfrini.
 
    ! Allocate internal arrays.
    call arallocf
    call arallocc_c
 
    ! Initialize some global variables.
    call bfrini
 
    ifopbf = 1
  endif
  if( (io=='FIRST') .or. (io=='QUIET') ) return
 
  ! See if a file can be opened
 
  call status(lunit,lun,il,im)
  if(lun==0) then
    write(bort_str,'("BUFRLIB: OPENBF - THERE ARE ALREADY",I3," BUFR FILES OPENED, CANNOT OPEN FILE CONNECTED TO UNIT",I4)') &
      nfiles,lunit
    call bort(bort_str)
  endif
  if(il/=0) then
    write(bort_str,'("BUFRLIB: OPENBF - THE FILE CONNECTED TO UNIT",I5," IS ALREADY OPEN")') lunit
    call bort(bort_str)
  endif
  null(lun) = 0
  isc3(lun) = 0
  iscodes(lun) = 0
  lus(lun) = 0
 
  ! Use inquire to obtain the filename associated with unit lunit
 
  if (io/='NUL' .and. io/='INUL') then
    inquire(lunit,access=fileacc)
    if(fileacc=='UNDEFINED') open(lunit)
    inquire(lunit,name=filename)
    filename=trim(filename)//char(0)
  endif
 
  nmsg(lun) = 0
  nsub(lun) = 0
  msub(lun) = 0
  inode(lun) = 0
  idate(lun) = 0
 
  ! Decide how to open the file and setup the dictionary
 
  if(io=='IN') then
    call openrb_c(lun,filename)
    call wtstat(lunit,lun,-1,0)
    call readdx(lunit,lun,lundx)
  else if(io=='INUL') then
    call wtstat(lunit,lun,-1,0)
    if(lunit/=lundx) call readdx(lunit,lun,lundx)
    null(lun) = 1
  else if(io=='NUL') then
    call wtstat(lunit,lun,1,0)
    if(lunit/=lundx) call readdx(lunit,lun,lundx)
    null(lun) = 1
  else if(io=='INX') then
    call openrb_c(lun,filename)
    call wtstat(lunit,lun,-1,0)
    null(lun) = 1
  else if(io=='OUX') then
    call openwb_c(lun,filename)
    call wtstat(lunit,lun,1,0)
  else if(io=='SEC3') then
    call openrb_c(lun,filename)
    call wtstat(lunit,lun,-1,0)
    isc3(lun) = 1
  else if(io=='OUT') then
    call openwb_c(lun,filename)
    call wtstat(lunit,lun,1,0)
    call writdx(lunit,lun,lundx)
  else if(io=='NODX') then
    call openwb_c(lun,filename)
    call wtstat(lunit,lun,1,0)
    call readdx(lunit,lun,lundx)
  else if(io=='APN' .or. io=='APX') then
    call openab_c(lun,filename)
    call wtstat(lunit,lun,1,0)
    if(lunit/=lundx) call readdx(lunit,lun,lundx)
    call posapx(lunit)
  else
    call bort('BUFRLIB: OPENBF - ILLEGAL SECOND (INPUT) ARGUMENT')
  endif
 
  return
end subroutine openbf
 
recursive subroutine closbf(lunit)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_nulbfr
 
  implicit none
 
  character*128 errstr
 
  integer, intent(in) :: lunit
  integer my_lunit, lun, il, im, bort_target_set
 
  ! Check for i8 integers
 
  if(im8b) then
     im8b=.false.
     call x84(lunit,my_lunit,1)
     call closbf(my_lunit)
     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_closbf_c(lunit)
    call bort_target_unset
    return
  endif
 
  if ( .not. allocated(null) ) then
    call errwrt('++++++++++++++++++++WARNING++++++++++++++++++++++')
    errstr = 'BUFRLIB: CLOSBF WAS CALLED WITHOUT HAVING PREVIOUSLY CALLED OPENBF'
    call errwrt(errstr)
    call errwrt('++++++++++++++++++++WARNING++++++++++++++++++++++')
    return
  endif
 
  call status(lunit,lun,il,im)
  if(il>0 .and. im/=0) call closmg(lunit)
  if(il/=0 .and. null(lun)==0) call closfb_c(lun)
  call wtstat(lunit,lun,0,0)
 
  ! Close Fortran unit if null(lun) = 0
 
  if(null(lun)==0) close(lunit)
 
  return
end subroutine closbf
 
recursive subroutine status(lunit,lun,il,im)
 
  use bufrlib
 
  use modv_vars, only: im8b, nfiles
 
  use moda_stbfr
 
  implicit none
 
  integer, intent(in) :: lunit
  integer, intent(out) :: lun, il, im
  integer my_lunit, i, bort_target_set
 
  character*128 bort_str, errstr
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call status(my_lunit,lun,il,im)
    call x48(lun,lun,1)
    call x48(il,il,1)
    call x48(im,im,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_status_c(lunit,lun,il,im)
    call bort_target_unset
    return
  endif
 
  if(lunit<=0 .or. lunit>99) then
    write(bort_str,'("BUFRLIB: STATUS - INPUT UNIT NUMBER (",I3,") OUTSIDE LEGAL RANGE OF 1-99")') lunit
    call bort(bort_str)
  endif
 
  ! Clear the status indicators
 
  lun = 0
  il  = 0
  im  = 0
 
  ! See if the unit is already connected to the library
 
  if ( .not. allocated(iolun) ) then
    call errwrt('++++++++++++++++++++WARNING++++++++++++++++++++++')
    errstr = 'BUFRLIB: STATUS WAS CALLED WITHOUT HAVING PREVIOUSLY CALLED OPENBF'
    call errwrt(errstr)
    call errwrt('++++++++++++++++++++WARNING++++++++++++++++++++++')
    return
  endif
 
  do i=1,nfiles
    if(abs(iolun(i))==lunit) lun = i
  enddo
 
  ! If not, try to define it so as to connect it to the library
 
  if(lun==0) then
    do i=1,nfiles
      if(iolun(i)==0) then
        ! File space is available, return with lun > 0, il and im remain 0
        lun = i
        return
      endif
    enddo
    ! File space is NOT available, return with lun, il and im all 0
    return
  endif
 
  ! If the unit was already connected to the library prior to this call, then return statuses
 
  il = sign(1,iolun(lun))
  im = iomsg(lun)
 
  return
end subroutine status
 
subroutine wtstat(lunit,lun,il,im)
 
  use moda_stbfr
 
  implicit none
 
  integer, intent(in) :: lunit, lun, il, im
 
  character*128 bort_str
 
  ! Check on the arguments
 
  if(lunit<=0) then
    write(bort_str,'("BUFRLIB: WTSTAT - INVALID UNIT NUMBER PASSED INTO FIRST ARGUMENT (INPUT) (=",I3,")")') lunit
    call bort(bort_str)
  endif
  if(lun<=0) then
    write(bort_str,'("BUFRLIB: WTSTAT - INVALID FILE ID PASSED INTO SECOND ARGUMENT (INPUT) (=",I3,")")') lun
    call bort(bort_str)
  endif
  if(il<-1 .or. il>1) then
    write(bort_str,'("BUFRLIB: WTSTAT - INVALID LOGICAL UNIT STATUS INDICATOR PASSED INTO THIRD ARGUMENT '// &
      '(INPUT) (=",I4,")")') il
    call bort(bort_str)
  endif
  if(im< 0 .or. im>1) then
    write(bort_str,'("BUFRLIB: WTSTAT - INVALID BUFR MESSAGE STATUS INDICATOR PASSED INTO FOURTH ARGUMENT '// &
      '(INPUT) (=",I4,")")') im
    call bort(bort_str)
  endif
 
  ! Check on lunit-lun combination
 
  if(abs(iolun(lun))/=lunit .and. (iolun(lun)/=0)) then
    write(bort_str,'("BUFRLIB: WTSTAT - ATTEMPTING TO REDEFINE EXISTING FILE UNIT (LOGICAL UNIT '// &
      'NUMBER ",I3,")")') iolun(lun)
    call bort(bort_str)
  endif
 
  ! Reset the file statuses
 
  if(il/=0) then
    iolun(lun) = sign(lunit,il)
    iomsg(lun) = im
  else
    iolun(lun) = 0
    iomsg(lun) = 0
  endif
 
  return
end subroutine wtstat
 
recursive subroutine ufbcnt(lunit,kmsg,ksub)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
 
  implicit none
 
  integer, intent(in) :: lunit
  integer, intent(out) :: kmsg, ksub
  integer my_lunit, lun, il, im, bort_target_set
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call ufbcnt(my_lunit,kmsg,ksub)
    call x48(kmsg,kmsg,1)
    call x48(ksub,ksub,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_ufbcnt_c(lunit, kmsg, ksub)
    call bort_target_unset
    return
  endif
 
  ! Check the file status - return the message and subset counters
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: UFBCNT - BUFR FILE IS CLOSED, IT MUST BE OPEN FOR EITHER INPUT OR OUTPUT')
  kmsg = nmsg(lun)
  ksub = nsub(lun)
 
  return
end subroutine ufbcnt
 
subroutine posapx(lunxx)
 
  use bufrlib
 
  use moda_mgwa
 
  implicit none
 
  integer, intent(in) :: lunxx
  integer lunit, lun, il, im, ier, idxmsg
 
  lunit = abs(lunxx)
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: POSAPX - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
  if(il<0) call bort('BUFRLIB: POSAPX - INPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
 
  ! Try to read to the end of the file
 
  do while (.true.)
    call rdmsgw(lunit,mgwa,ier)
    if(ier<0) return
    if(idxmsg(mgwa)==1) then
      ! This is an internal dictionary message that was generated by the NCEPLIBS-bufr software.  Backspace the file pointer
      ! and then read and store all such dictionary messages (they should be stored consecutively!) and reset the internal tables.
      call backbufr_c(lun)
      call rdbfdx(lunit,lun)
    endif
  enddo
 
end subroutine posapx
 
subroutine rewnbf(lunit,isr)
 
  use bufrlib
 
  use moda_msgcwd
  use moda_bitbuf
  use moda_bufrsr
 
  implicit none
 
  integer, intent(in) :: lunit, isr
  integer lun, il, im, i, kdate, ier
 
  character*128 bort_str
  character*8 subset
 
  ! Try to trap bad call problems
  if(isr==0) then
    call status(lunit,lun,il,im)
    if(jsr(lun)/=0) then
      write(bort_str,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// &
        'PARAMETERS FOR FILE FOR WHICH THEY HAVE ALREADY BEEN SAVED (AND NOT YET RESTORED) (UNIT",I3,")")') lunit
      call bort(bort_str)
    endif
    if(il==0) then
      write(bort_str,'("BUFRLIB: REWNBF - ATTEMPING TO SAVE '// &
        'PARAMETERS FOR BUFR FILE WHICH IS NOT OPENED FOR EITHER INPUT OR OUTPUT) (UNIT",I3,")")') lunit
      call bort(bort_str)
    endif
  elseif(isr==1) then
    if(junn==0) then
      write(bort_str,'("BUFRLIB: REWNBF - ATTEMPING TO RESTORE '// &
        'PARAMETERS TO BUFR FILE WHICH WERE NEVER SAVED (UNIT",I3,")")') lunit
      call bort(bort_str)
    endif
    if(jsr(junn)/=1) then
      write(bort_str,'("BUFRLIB: REWNBF - ATTEMPING TO RESTORE '// &
        'PARAMETERS TO BUFR FILE WHICH WERE NEVER SAVED (UNIT",I3,")")') lunit
      call bort(bort_str)
    endif
    lun = junn
  else
     write(bort_str,'("BUFRLIB: REWNBF - SAVE/RESTORE SWITCH (INPUT '// &
      'ARGUMENT ISR) IS NOT ZERO OR ONE (HERE =",I4,") (UNIT",I3,")")') isr, lunit
     call bort(bort_str)
  endif
 
  if(isr==0) then
    ! Store the existing file parameters
    jmsg = nmsg(lun)
    jsub = nsub(lun)
    if ( il > 0 ) then
      ! The file is open for writing
      jbit = ibit
      jbyt = mbyt(lun)
      do i=1,jbyt
        jbay(i) = mbay(i,lun)
      enddo
    endif
    junn = lun
    jill = il
    jimm = im
    ! Reset the file for reading
    call wtstat(lunit,lun,-1,0)
  endif
 
  ! Rewind the file
  call cewind_c(lun)
 
  if(isr==1) then
    ! Restore the previous file parameters. Note that we already restored the previous value of lun earlier in this routine.
 
    ! Reset nmsg(lun) to 0, so that the below calls to readmg() will internally restore nmsg(lun) to the correct value.
    nmsg(lun) = 0
 
    ! Note that the below calls to readmg() are valid even if the file was previously open for writing, because we haven't yet
    ! called wtstat() to restore the file to its previous I/O status.  So until then we can still read from it as though it
    ! was an input file.
    do i=1,jmsg
      call readmg(lunit,subset,kdate,ier)
      if(ier<0) then
        write(bort_str,'("BUFRLIB: REWNBF - HIT END OF FILE BEFORE '// &
          'REPOSITIONING BUFR FILE IN UNIT",I3," TO ORIGINAL MESSAGE NO.",I5)') lunit, jmsg
        call bort(bort_str)
      endif
    enddo
 
    if ( jill < 0 ) then
      ! The file was previously open for reading
      do i=1,jsub
        call readsb(lunit,ier)
      enddo
    else
      ! The file was previously open for writing
      do i=1,jbyt
        mbay(i,lun) = jbay(i)
      enddo
      nsub(lun) = jsub
      mbyt(lun) = jbyt
      ibit = jbit
    endif
 
    ! Now restore the file to its previous I/O status
    il = jill
    im = jimm
    call wtstat(lunit,lun,il,im)
  endif
 
  ! Toggle the stack status indicator
  jsr(lun) = mod(jsr(lun)+1,2)
 
  return
end subroutine rewnbf
 
 
recursive subroutine ufbtab(lunin,tab,i1,i2,iret,str)
 
  use bufrlib
 
  use modv_vars, only: part, im8b, bmiss, iac, iprt
 
  use moda_usrint
  use moda_msgcwd
  use moda_unptyp
  use moda_bitbuf
  use moda_tables
 
  implicit none
 
  integer*8 ival, lref, ninc, mps, lps
  integer, intent(in) :: lunin, i1, i2
  integer, intent(inout) :: iret
  integer, parameter :: maxtg = 100
  integer nnod, ncon, nods, nodc, ivls, kons, my_lunin, my_i1, my_i2, lunit, lun, il, im, irec, isub, i, n, ntg, &
    jdate, jbit, kbit, lbit, mbit, nbit, nibit, nbyt, nsb, node, nbmp, nrep, lret, linc, iac_prev, ityp, &
    ireadmg, ireadsb, nmsub, lcstr, bort_target_set
 
  character*(*), intent(in) :: str
  character*128 errstr
  character*90 cstr
  character*40 cref
  character*10 tgs(maxtg)
  character*8 subset, cval
 
  logical :: openit, overflow, just_count, need_node, need_newmsg
 
  real*8, intent(out) :: tab(i1,i2)
  real*8 rval, ups
 
  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
 
  save lun, openit
 
  equivalence(cval,rval)
 
  ! Statement functions
  mps(node) = 2_8**(ibt(node))-1
  lps(lbit) = max(2_8**(lbit)-1,1)
 
  ! Check for I8 integers
  if(im8b) then
    im8b=.false.
    call x84(lunin,my_lunin,1)
    call x84(i1,my_i1,1)
    call x84(i2,my_i2,1)
    call ufbtab(my_lunin,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_ufbtab_c(lunin,tab,i1,i2,iret,cstr,lcstr)
    call bort_target_unset
    return
  endif
 
  ! Set counters to zero
  irec = 0
  isub = 0
 
  ! Initialize all of the output array values to the current value for "missing"
  tab(1:i1,1:i2) = bmiss
 
  iac_prev = iac
  iac = 1
 
  lunit = abs(lunin)
  just_count = lunin<lunit
  if (.not. just_count) then
    ! Check for special tags in string
    call parstr(str,tgs,maxtg,ntg,' ',.true.)
    do i=1,ntg
      if(tgs(i)=='IREC') irec = i
      if(tgs(i)=='ISUB') isub = i
    enddo
  endif
 
  overflow = .false.
 
  if(part.and.iret<0) then
    ! The previous call to this subroutine only partially read through the file, so resume reading from
    ! the point where it previously left off.
    need_newmsg = .false.
    iret = 0
  else
    ! Make sure subroutine openbf() has been called at least once before trying to call subroutine status();
    ! otherwise, status() might try to access array space that hasn't yet been dynamically allocated.
    call openbf(0,'FIRST',0)
    call status(lunit,lun,il,im)
    openit = il==0
    if(openit) then
      ! Open BUFR file connected to unit lunit if it isn't already open
      call openbf(lunit,'INX',lunit)
    else
      ! If BUFR file already opened, save position and rewind to first data message
      call rewnbf(lunit,0)
    endif
    need_newmsg = .true.
    iret = 0
    ! Check for count subset only option
    if(just_count) then
      do while(ireadmg(-lunit,subset,jdate)>=0)
        iret = iret+nmsub(lunit)
      enddo
    endif
  endif
 
  outer: do while (.not. just_count)
 
    if(need_newmsg) then
      ! Read the next message from the file
      if(ireadmg(-lunit,subset,jdate)<0) exit
      call string(str,lun,i1,0)
      if(irec>0) nods(irec) = 0
      if(isub>0) nods(isub) = 0
    else
      need_newmsg=.true.
    endif
 
    if(msgunp(lun)/=2) then
      ! The message is uncompressed
 
      inner1: do while (.true.)
        ! Get the next subset from the message
        if(nsub(lun)==msub(lun)) cycle outer
        if(iret+1>i2) then
          if(part) then
            iret=-iret
            return
          else
            overflow = .true.
            exit outer
          endif
        endif
        iret = iret+1
        do i=1,nnod
          nods(i) = abs(nods(i))
        enddo
        if(msgunp(lun)==0) then
          mbit = mbyt(lun)*8 + 16
        else
          mbit = mbyt(lun)
        endif
        nbit = 0
        n = 1
        call usrtpl(lun,n,n)
        inner2: do while (.true.)
          ! Cycle through each node of the subset to look for the requested values
          if(n+1<=nval(lun)) then
            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 inner2
              endif
            enddo
            do i=1,nnod
              if(nods(i)>0) cycle inner2
            enddo
          endif
          exit
        enddo inner2
        ! Update the subset pointers
        if(msgunp(lun)==0) then
          ibit = mbyt(lun)*8
          call upb(nbyt,16,mbay(1,lun),ibit)
          mbyt(lun) = mbyt(lun) + nbyt
        else
          mbyt(lun) = mbit
        endif
        nsub(lun) = nsub(lun) + 1
        if(irec>0) tab(irec,iret) = nmsg(lun)
        if(isub>0) tab(isub,iret) = nsub(lun)
      enddo inner1
 
    else
      ! The message is compressed
 
      if(iret+msub(lun)>i2) then
        if(part) then
          iret=-iret
          return
        else
          overflow = .true.
          exit outer
        endif
      endif
      if(irec>0.or.isub>0) then
        do nsb=1,msub(lun)
          if(irec>0) tab(irec,iret+nsb) = nmsg(lun)
          if(isub>0) tab(isub,iret+nsb) = nsb
        enddo
      endif
      call usrtpl(lun,1,1)
      ibit = mbyt(lun)
      n = 0
      inner3: do while ( n < nval(lun) )
        ! Cycle through each node of each subset to look for the requested values
        n = n+1
        node = inv(n,lun)
        nbit = ibt(node)
        ityp = itp(node)
        if(n==1) then
          ! Reset the node indices
          do i=1,nnod
            nods(i) = abs(nods(i))
          enddo
        else
          ! Are we still looking for more values?
          need_node = .false.
          do i=1,nnod
            if(nods(i)>0) then
              need_node = .true.
              exit
            endif
          enddo
          if(.not. need_node) exit inner3
        endif
        if(ityp==1 .or. ityp==2) then
          call up8(lref,nbit,mbay(1,lun),ibit)
          call upb(linc,6,mbay(1,lun),ibit)
          nibit = ibit + linc*msub(lun)
        elseif(ityp==3) then
          cref=' '
          call upc(cref,nbit/8,mbay(1,lun),ibit,.true.)
          call upb(linc,6,mbay(1,lun),ibit)
          nibit = ibit + 8*linc*msub(lun)
        else
          cycle
        endif
        if(ityp==1) then
          ! This is a delayed replication node
          jbit = ibit + linc
          call up8(ninc,linc,mbay(1,lun),jbit)
          ival = lref+ninc
          call usrtpl(lun,n,int(ival))
          cycle
        endif
        do i=1,nnod
          if(node==nods(i)) then
            ! This is one of the requested values, so store the corresponding value from each subset in the message
            nods(i) = -nods(i)
            lret = iret
            if(ityp==1 .or. ityp==2) then
              do nsb=1,msub(lun)
                jbit = ibit + linc*(nsb-1)
                call up8(ninc,linc,mbay(1,lun),jbit)
                ival = lref+ninc
                lret = lret+1
                if(ninc<lps(linc)) tab(i,lret) = ups(ival,node)
              enddo
            elseif(ityp==3) then
              do nsb=1,msub(lun)
                if(linc==0) then
                  cval = cref(1:8)
                else
                  jbit = ibit + linc*(nsb-1)*8
                  cval = ' '
                  call upc(cval,linc,mbay(1,lun),jbit,.true.)
                endif
                lret = lret+1
                tab(i,lret) = rval
              enddo
            else
              call bort('UFBTAB - INVALID ELEMENT TYPE SPECIFIED')
            endif
          endif
        enddo
        ibit = nibit
      enddo inner3
      iret = iret+msub(lun)
 
    endif
 
  enddo outer
 
  if(overflow) then
    nrep = iret
    do while(ireadsb(lunit)==0)
      nrep = nrep+1
    enddo
    do while(ireadmg(-lunit,subset,jdate)>=0)
      nrep = nrep+nmsub(lunit)
    enddo
    if(iprt>=0) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      write ( unit=errstr, fmt='(A,A,I8,A)' ) 'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ', &
        .GT.'IS  LIMIT OF ', i2, ' IN THE 4TH ARG. (INPUT) - INCOMPLETE READ'
      call errwrt(errstr)
      write ( unit=errstr, fmt='(A,I8,A,I8,A)' ) '>>>UFBTAB STORED ', iret, ' REPORTS OUT OF ', nrep, '<<<'
      call errwrt(errstr)
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      call errwrt(' ')
    endif
  endif
 
  if(openit) then
    ! Close BUFR file if it was opened here
    call closbf(lunit)
  else
    ! Restore BUFR file to its previous status and position
    call rewnbf(lunit,1)
  endif
 
  iac = iac_prev
 
  return
end subroutine ufbtab
 
subroutine setpart ( xpart )
 
  use modv_vars, only: part
 
  implicit none
 
  logical, intent(in) :: xpart
 
  part = xpart
 
  return
end subroutine setpart