copydata.F90

Go to the documentation of this file.

 
 
recursive subroutine copybf(lunin,lunot)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_mgwa
 
  implicit none
 
  integer, intent(in) :: lunin, lunot
  integer my_lunin, my_lunot, lun, il, im, ier, iupbs01, bort_target_set
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunin,my_lunin,1)
    call x84(lunot,my_lunot,1)
    call copybf(my_lunin,my_lunot)
    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_copybf_c(lunin,lunot)
    call bort_target_unset
    return
  endif
 
  ! Check BUFR file statuses
 
  call status(lunin,lun,il,im)
  if(il/=0) call bort ('BUFRLIB: COPYBF - INPUT BUFR FILE IS OPEN, IT MUST BE CLOSED')
  call status(lunot,lun,il,im)
  if(il/=0) call bort ('BUFRLIB: COPYBF - OUTPUT BUFR FILE IS OPEN, IT MUST BE CLOSED')
 
  ! Connect the files for reading/writing to the C I/O interface
 
  call openbf(lunin,'INX',lunin)
  call openbf(lunot,'OUX',lunin)
 
  ! Read and copy a BUFR file from unit lunin to unit lunot
 
  ier = 0
  do while (ier==0)
    call rdmsgw(lunin,mgwa,ier)
    if(ier==0) call msgwrt(lunot,mgwa,iupbs01(mgwa,'LENM'))
  enddo
 
  ! Free up the file connections for the two files
 
  call closbf(lunin)
  call closbf(lunot)
 
  return
end subroutine copybf
 
recursive subroutine copymg(lunin,lunot)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
  use moda_bitbuf
  use moda_tables
 
  implicit none
 
  integer, intent(in) :: lunin, lunot
  integer my_lunin, my_lunot, lin, lot, il, im, mtyp, msbt, inod, mbym, iupbs01, iok2cpy, bort_target_set
 
  character*8 subset
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunin,my_lunin,1)
    call x84(lunot,my_lunot,1)
    call copymg(my_lunin,my_lunot)
    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_copymg_c(lunin,lunot)
    call bort_target_unset
    return
  endif
 
  ! Check the file statuses
 
  call status(lunin,lin,il,im)
  if(il==0) call bort('BUFRLIB: COPYMG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
  if(il>0) call bort('BUFRLIB: COPYMG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
  if(im==0) call bort('BUFRLIB: COPYMG - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
 
  call status(lunot,lot,il,im)
  if(il==0) call bort('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
  if(il<0) call bort('BUFRLIB: COPYMG - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
  if(im/=0) call bort('BUFRLIB: COPYMG - ALL MESSAGES MUST BE CLOSED IN OUTPUT BUFR FILE, A MESSAGE IS OPEN')
 
  ! Make sure both files have the same tables
 
  subset = tag(inode(lin))(1:8)
  call nemtba(lot,subset,mtyp,msbt,inod)
  if(inode(lin)/=inod .and. iok2cpy(lin,lot)/=1) &
    call bort('BUFRLIB: COPYMG - INPUT AND OUTPUT BUFR FILES MUST HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
 
  ! Everything okay, so copy a message
 
  mbym = iupbs01(mbay(1,lin),'LENM')
  call msgwrt(lunot,mbay(1,lin),mbym)
 
  ! Set the message control words for partition associated with lunot
 
  nmsg(lot) = nmsg(lot) + 1
  nsub(lot) = msub(lin)
  msub(lot) = msub(lin)
  idate(lot) = idate(lin)
  inode(lot) = inod
 
  return
end subroutine copymg
 
recursive subroutine copysb(lunin,lunot,iret)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
  use moda_bitbuf
  use moda_tables
 
  implicit none
 
  integer, intent(in) :: lunin, lunot
  integer, intent(out) :: iret
  integer my_lunin, my_lunot, lin, lot, il, im, mest, icmp, nbyt, len0, len1, len2, len3, len4, l5, iok2cpy, bort_target_set
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunin,my_lunin,1)
    call x84(lunot,my_lunot,1)
    call copysb(my_lunin,my_lunot,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_copysb_c(lunin,lunot,iret)
    call bort_target_unset
    return
  endif
 
  iret = 0
 
  ! Check the file statuses
 
  call status(lunin,lin,il,im)
  if(il==0) call bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
  if(il>0) call bort('BUFRLIB: COPYSB - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
  if(im==0) call bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
 
  if(lunot>0) then
    call status(lunot,lot,il,im)
    if(il==0) call bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
    if(il<0) call bort('BUFRLIB: COPYSB - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
    if(im==0) call bort('BUFRLIB: COPYSB - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
    if( (inode(lin)/=inode(lot)) .and. ( (tag(inode(lin))/=tag(inode(lot))) .or. (iok2cpy(lin,lot)/=1) ) ) &
      call bort('BUFRLIB: COPYSB - INPUT AND OUTPUT BUFR FILES MUST HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
  endif
 
  ! See if there is another subset in the message
 
  if(nsub(lin)==msub(lin)) then
    iret = -1
    return
  endif
 
  ! Check compression status of input message, output message will match
 
  call mesgbc(-lunin, mest, icmp)
 
  if(icmp==1) then
 
    ! The input message is compressed, so read in the next subset and copy it as compressed to the output message.
 
    call readsb(lunin,iret)
    if(lunot>0) then
      call ufbcpy(lunin,lunot)
      call cmpmsg('Y')
      call writsb(lunot)
      call cmpmsg('N')
    endif
  else
 
    ! The input message is uncompressed, so read in the next subset and copy it as uncompressed to the output message.
 
    ibit = (mbyt(lin))*8
    call upb(nbyt,16,mbay(1,lin),ibit)
    if (nbyt>65530) then
      ! This is an oversized subset, so we can't rely on the value of nbyt as being the true size (in bytes) of the subset.
      if ( (nsub(lin)==0) .and. (msub(lin)==1) ) then
        ! But it's also the first and only subset in the message, so we can determine its true size in a different way.
        call getlens(mbay(1,lin), 4, len0, len1, len2, len3, len4, l5)
        nbyt = len4 - 4
      else
        ! We have no way to easily determine the true size of this oversized subset.
        iret = -1
        return
      endif
    endif
    if(lunot>0) call cpyupd(lunot, lin, lot, nbyt)
    mbyt(lin) = mbyt(lin) + nbyt
    nsub(lin) = nsub(lin) + 1
  endif
 
  return
end subroutine copysb
 
recursive integer function icopysb(lunin,lunot) result(iret)
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(in) :: lunin, lunot
  integer my_lunin, my_lunot
 
  if(im8b) then
    im8b=.false.
    call x84(lunin,my_lunin,1)
    call x84(lunot,my_lunot,1)
    iret=icopysb(my_lunin,my_lunot)
    im8b=.true.
    return
  endif
 
  call copysb(lunin,lunot,iret)
 
  return
end function icopysb
 
integer function iok2cpy(lui,luo) result(iret)
 
  use moda_msgcwd
  use moda_tables
 
  implicit none
 
  integer, intent(in) :: lui, luo
  integer icmpdx, mtyp, msbt, inod, ntei, nteo, i
 
  character*8 subset
 
  iret = 0
 
  ! Do both logical units have the same internal table information?
 
  if ( icmpdx(lui,luo) == 1 ) then
    iret = 1
    return
  endif
 
  ! No, so get the Table A mnemonic from the message to be copied, then check whether that mnemonic is defined within the
  ! dictionary tables for the logical unit to be copied to.
 
  subset = tag(inode(lui))(1:8)
  call nemtbax(luo,subset,mtyp,msbt,inod)
  if ( inod == 0 ) return
 
  ! The Table A mnemonic is defined within the dictionary tables for both units, so now make sure the definitions are identical.
 
  ntei = isc(inode(lui))-inode(lui)
  nteo = isc(inod)-inod
  if ( ntei /= nteo ) return
 
  do i = 1, ntei
    if ( tag(inode(lui)+i) /= tag(inod+i) ) return
    if ( typ(inode(lui)+i) /= typ(inod+i) ) return
    if ( isc(inode(lui)+i) /= isc(inod+i) ) return
    if ( irf(inode(lui)+i) /= irf(inod+i) ) return
    if ( ibt(inode(lui)+i) /= ibt(inod+i) ) return
  enddo
 
  iret = 1
 
  return
end function iok2cpy
 
recursive subroutine cpymem(lunot)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_msgcwd
  use moda_bitbuf
  use moda_msgmem
  use moda_tables
 
  implicit none
 
  integer, intent(in) :: lunot
  integer my_lunot, lin, lot, il, im, mtyp, msbt, inod, mbym, iupbs01, iok2cpy, bort_target_set
 
  character*8  subset
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunot,my_lunot,1)
    call cpymem(my_lunot)
    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_cpymem_c(lunot)
    call bort_target_unset
    return
  endif
 
  ! Check the file statuses
 
  call status(munit,lin,il,im)
  if(im==0) call bort('BUFRLIB: CPYMEM - A MESSAGE MUST BE OPEN IN INPUT BUFR MESSAGES IN INTERNAL MEMORY, NONE ARE')
 
  call status(lunot,lot,il,im)
  if(il==0) call bort('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
  if(il<0) call bort('BUFRLIB: CPYMEM - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
  if(im/=0) call bort('BUFRLIB: CPYMEM - ALL MESSAGES MUST BE CLOSED IN OUTPUT BUFR FILE, A MESSAGE IS OPEN')
 
  ! Make sure both files have the same tables
 
  subset = tag(inode(lin))(1:8)
  call nemtba(lot,subset,mtyp,msbt,inod)
  if(inode(lin)/=inod .and. iok2cpy(lin,lot)/=1) &
    call bort('BUFRLIB: CPYMEM - INPUT BUFR MESSAGES IN INTERNAL MEMORY AND OUTPUT BUFR FILE MUST HAVE SAME INTERNAL '// &
      'TABLES (DIFFERENT HERE)')
 
  ! Everything okay, so copy a message
 
  mbym = iupbs01(mbay(1,lin),'LENM')
  call msgwrt(lunot,mbay(1,lin),mbym)
 
  ! Set the message control words for partition associated with lunot
 
  nmsg(lot) = nmsg(lot) + 1
  nsub(lot) = msub(lin)
  msub(lot) = msub(lin)
  idate(lot) = idate(lin)
  inode(lot) = inod
 
  return
end subroutine cpymem
 
subroutine cpyupd(lunit,lin,lun,ibyt)
 
  use modv_vars, only: iprt, nby0, nby1, nby2, nby3
 
  use moda_msgcwd
  use moda_bitbuf
 
  implicit none
 
  integer, intent(in) :: lunit, lin, lun, ibyt
  integer lbit, lbyt, nbyt, iupb
 
  character*128 bort_str, errstr
 
  logical msgfull
 
  ! Check whether the new subset should be written into the currently open message
 
  if(msgfull(mbyt(lun),ibyt,maxbyt) .or. ((ibyt>65530).and.(nsub(lun)>0))) then
    ! NO it should not, either because:
    !  1) it doesn't fit,
    !          -- OR --
    !  2) it has byte count > 65530 (sufficiently close to the upper limit for the 16 bit byte counter placed at the
    !     beginning of each subset), AND the current message has at least one subset in it,
    ! SO write the current message out and create a new one to  hold the current subset
    call msgwrt(lunit,mbay(1,lun),mbyt(lun))
    call msgini(lun)
  endif
 
  if(msgfull(mbyt(lun),ibyt,maxbyt)) then
    write(bort_str,'("BUFRLIB: CPYUPD - THE LENGTH OF THIS SUBSET EXCEEDS THE MAXIMUM MESSAGE LENGTH (",I6,")")') maxbyt
    call bort(bort_str)
  endif
 
  ! Transfer subset from one message to the other.
 
  ! Note that we want to append the data for this subset to the end of Section 4, but the value in mbyt(lun) already includes
  ! the length of Section 5 (i.e. 4 bytes).  Therefore, we need to begin writing at the point 3 bytes prior to the byte
  ! currently pointed to by mbyt(lun).
 
  call mvb(mbay(1,lin),mbyt(lin)+1,mbay(1,lun),mbyt(lun)-3,ibyt)
 
  ! Update the subset and byte counters
 
  mbyt(lun) = mbyt(lun) + ibyt
  nsub(lun) = nsub(lun) + 1
 
  lbit = (nby0+nby1+nby2+4)*8
  call pkb(nsub(lun),16,mbay(1,lun),lbit)
 
  lbyt = nby0+nby1+nby2+nby3
  nbyt = iupb(mbay(1,lun),lbyt+1,24)
  lbit = lbyt*8
  call pkb(nbyt+ibyt,24,mbay(1,lun),lbit)
 
  ! If the subset byte count is > 65530, then give it its own one-subset message (i.e. we cannot have any other subsets
  ! in this message because their beginning would be beyond the upper limit of 65535 in the 16-bit byte counter, meaning
  ! they could not be located!)
 
  if(ibyt>65530) then
    if(iprt>=1) then
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      write ( unit=errstr, fmt='(A,I7,A,A)') 'BUFRLIB: CPYUPD - SUBSET HAS BYTE COUNT = ',ibyt,' > UPPER LIMIT OF 65535'
      call errwrt(errstr)
      call errwrt('>>>>>>>WILL BE COPIED INTO ITS OWN MESSAGE<<<<<<<<')
      call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
      call errwrt(' ')
    endif
    call msgwrt(lunit,mbay(1,lun),mbyt(lun))
    call msgini(lun)
  endif
 
  return
end subroutine cpyupd
 
recursive subroutine ufbcpy(lubin,lubot)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_usrint
  use moda_msgcwd
  use moda_ufbcpl
  use moda_tables
 
  implicit none
 
  integer, intent(in) :: lubin, lubot
  integer my_lubin, my_lubot, lui, luo, il, im, n, iok2cpy, bort_target_set
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lubin,my_lubin,1)
    call x84(lubot,my_lubot,1)
    call ufbcpy(my_lubin,my_lubot)
    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_ufbcpy_c(lubin,lubot)
    call bort_target_unset
    return
  endif
 
  ! Check the file statuses and inode
 
  call status(lubin,lui,il,im)
  if(il==0) call bort('BUFRLIB: UFBCPY - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
  if(il>0) call bort('BUFRLIB: UFBCPY - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
  if(im==0) call bort('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
  if(inode(lui)/=inv(1,lui)) &
    call bort('BUFRLIB: UFBCPY - LOCATION OF INTERNAL TABLE FOR INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION '// &
      'IN INTERNAL SUBSET ARRAY')
 
  call status(lubot,luo,il,im)
  if(il==0) call bort('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
  if(il<0) call bort('BUFRLIB: UFBCPY - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
  if(im==0) call bort('BUFRLIB: UFBCPY - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
 
  if( (inode(lui)/=inode(luo)) .and. ( (tag(inode(lui))/=tag(inode(luo))) .or. (iok2cpy(lui,luo)/=1) ) ) &
    call bort('BUFRLIB: UFBCPY - INPUT AND OUTPUT BUFR FILES MUST HAVE THE SAME INTERNAL TABLES, THEY ARE DIFFERENT HERE')
 
  ! Everything okay, so copy user array from lui to luo
 
  nval(luo) = nval(lui)
 
  do n=1,nval(lui)
    inv(n,luo) = inv(n,lui)
    nrfelm(n,luo) = nrfelm(n,lui)
    val(n,luo) = val(n,lui)
  enddo
 
  luncpy(luo)=lubin
 
  return
end subroutine ufbcpy
 
subroutine cpbfdx(lud,lun)
 
  use moda_msgcwd
  use moda_tababd
 
  implicit none
 
  integer, intent(in) :: lud, lun
  integer i
 
  ! Initialize the dictionary table partition
 
  call dxinit(lun,0)
 
  ! Positional index for Table A mnem.
  inode(lun) = inode(lud)
 
  ntba(lun) = ntba(lud)
  ntbb(lun) = ntbb(lud)
  ntbd(lun) = ntbd(lud)
 
  ! Table A entries
  do i=1,ntba(lud)
    idna(i,lun,1) = idna(i,lud,1)
    idna(i,lun,2) = idna(i,lud,2)
    taba(i,lun) = taba(i,lud)
    mtab(i,lun) = mtab(i,lud)
  enddo
 
  ! Table B entries
  do i=1,ntbb(lud)
    idnb(i,lun) = idnb(i,lud)
    tabb(i,lun) = tabb(i,lud)
  enddo
 
  ! Copy Table D entries
  do i=1,ntbd(lud)
    idnd(i,lun) = idnd(i,lud)
    tabd(i,lun) = tabd(i,lud)
  enddo
 
  return
end subroutine cpbfdx
 
subroutine mvb(ib1,nb1,ib2,nb2,nbm)
 
  implicit none
 
  integer, intent(in) :: ib1(*), nb1, nb2, nbm
  integer, intent(out) :: ib2(*)
  integer jb1, jb2, n, nval
 
  jb1 = 8*(nb1-1)
  jb2 = 8*(nb2-1)
 
  do n=1,nbm
    call upb(nval,8,ib1,jb1)
    call pkb(nval,8,ib2,jb2)
  enddo
 
  return
end subroutine mvb
 
recursive subroutine ufbcup(lubin,lubot)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_usrint
  use moda_msgcwd
  use moda_tables
  use moda_ivttmp
 
  implicit none
 
  integer, intent(in) :: lubin, lubot
  integer my_lubin, my_lubot, lui, luo, il, im, ntag, ni, no, nv, nin, bort_target_set
 
  character*10 tago
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lubin,my_lubin,1)
    call x84(lubot,my_lubot,1)
    call ufbcup(my_lubin,my_lubot)
    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_ufbcup_c(lubin,lubot)
    call bort_target_unset
    return
  endif
 
 
  ! Check the file statuses and inode
 
  call status(lubin,lui,il,im)
  if(il==0) call bort('BUFRLIB: UFBCUP - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
  if(il>0) call bort('BUFRLIB: UFBCUP - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
  if(im==0) call bort('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
  if(inode(lui)/=inv(1,lui)) call bort('BUFRLIB: UFBCUP - LOCATION OF INTERNAL TABLE FOR '// &
    'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN INTERNAL SUBSET ARRAY')
 
  call status(lubot,luo,il,im)
  if(il==0) call bort('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR OUTPUT')
  if(il<0) call bort('BUFRLIB: UFBCUP - OUTPUT BUFR FILE IS OPEN FOR INPUT, IT MUST BE OPEN FOR OUTPUT')
  if(im==0) call bort('BUFRLIB: UFBCUP - A MESSAGE MUST BE OPEN IN OUTPUT BUFR FILE, NONE ARE')
 
  ! Make a list of unique tags in the input buffer
 
  ntag = 0
 
  outer1: do ni=1,nval(lui)
    nin = inv(ni,lui)
    if(itp(nin)>=2) then
      do nv=1,ntag
        if(ttmp(nv)==tag(nin)) cycle outer1
      enddo
      ntag = ntag+1
      itmp(ntag) = ni
      ttmp(ntag) = tag(nin)
    endif
  enddo outer1
 
  if(ntag==0) call bort('BUFRLIB: UFBCUP - THERE ARE NO ELEMENTS (TAGS) IN INPUT SUBSET BUFFER')
 
  ! Now, using the list of unique tags, make one copy of the common elements to the output buffer
 
  outer2: do nv=1,ntag
    ni = itmp(nv)
    do no=1,nval(luo)
      tago = tag(inv(no,luo))
      if(ttmp(nv)==tago) then
        val(no,luo) = val(ni,lui)
        cycle outer2
      endif
    enddo
  enddo outer2
 
  return
end subroutine ufbcup