tankrcpt.F90

Go to the documentation of this file.

 
 
recursive subroutine atrcpt(msgin,lmsgot,msgot)
 
  use bufrlib
 
  use modv_vars, only: im8b, nbytw
 
  use moda_tnkrcp
 
  implicit none
 
  integer, intent(in) :: msgin(*), lmsgot
  integer, intent(out) :: msgot(*)
  integer my_lmsgot, len0, len1, l2, l3, l4, l5, iad1, iad2, lenm, lenmot, len1ot, ibit, iupbs01, bort_target_set
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
    call x84(lmsgot, my_lmsgot, 1)
    call atrcpt(msgin, my_lmsgot*2, msgot)
    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_atrcpt_c(msgin,lmsgot,msgot)
    call bort_target_unset
    return
  endif
 
  ! Get some section lengths and addresses from the input message.
 
  call getlens(msgin,1,len0,len1,l2,l3,l4,l5)
 
  iad1 = len0
  iad2 = iad1 + len1
 
  lenm = iupbs01(msgin,'LENM')
 
  ! Check for overflow of the output array.  Note that the new message will be 6 bytes longer than the input message.
 
  lenmot = lenm + 6
  if(lenmot>(lmsgot*nbytw)) &
    call bort('BUFRLIB: ATRCPT - OVERFLOW OF OUTPUT MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY')
 
  len1ot = len1 + 6
 
  ! 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 mvb ( msgin, 8, msgot, 8, 1 )
 
  ! Store the length of the new Section 1.
 
  ibit = iad1*8
  call pkb ( len1ot, 24, msgot, ibit )
 
  ! Copy the remainder of Section 1 from the input array to the output array.
 
  call mvb ( msgin, iad1+4, msgot, (ibit/8)+1, len1-3 )
 
  ! Append the tank receipt time data to the new Section 1.
 
  ibit = iad2*8
  call pkb ( itryr, 16, msgot, ibit )
  call pkb ( itrmo,  8, msgot, ibit )
  call pkb ( itrdy,  8, msgot, ibit )
  call pkb ( itrhr,  8, msgot, ibit )
  call pkb ( itrmi,  8, msgot, ibit )
 
  ! Copy Sections 2, 3, 4 and 5 from the input array to the output array.
 
  call mvb ( msgin, iad2+1, msgot, (ibit/8)+1, lenm-iad2 )
 
  return
end subroutine atrcpt
 
recursive subroutine rtrcptb(mbay,iyr,imo,idy,ihr,imi,iret)
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(in) :: mbay(*)
  integer, intent(out) :: iyr, imo, idy, ihr, imi, iret
  integer is1byt, imgbyt, iupbs01, iupb
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
    call rtrcptb(mbay,iyr,imo,idy,ihr,imi,iret)
    call x48(iyr,iyr,1)
    call x48(imo,imo,1)
    call x48(idy,idy,1)
    call x48(ihr,ihr,1)
    call x48(imi,imi,1)
    call x48(iret,iret,1)
    im8b=.true.
    return
  endif
 
  iret = -1
 
  ! Check whether the message contains a tank receipt time.
 
  if(iupbs01(mbay,'BEN')==4) then
    is1byt = 23
  else
    is1byt = 19
  endif
  if( (is1byt+5) > iupbs01(mbay,'LEN1') ) return
 
  ! Unpack the tank receipt time.
 
  ! Note that is1byt is a starting byte number relative to the beginning of Section 1, so we still need to account for
  ! Section 0 when specifying the actual byte numbers to unpack within the overall message.
 
  imgbyt = is1byt + iupbs01(mbay,'LEN0')
 
  iyr = iupb(mbay,imgbyt,16)
  imo = iupb(mbay,imgbyt+2,8)
  idy = iupb(mbay,imgbyt+3,8)
  ihr = iupb(mbay,imgbyt+4,8)
  imi = iupb(mbay,imgbyt+5,8)
 
  iret = 0
 
  return
end subroutine rtrcptb
 
recursive subroutine rtrcpt(lunit,iyr,imo,idy,ihr,imi,iret)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_bitbuf
 
  implicit none
 
  integer, intent(in) :: lunit
  integer, intent(out) :: iyr, imo, idy, ihr, imi, iret
  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 rtrcpt(my_lunit,iyr,imo,idy,ihr,imi,iret)
    call x48(iyr,iyr,1)
    call x48(imo,imo,1)
    call x48(idy,idy,1)
    call x48(ihr,ihr,1)
    call x48(imi,imi,1)
    call x48(iret,iret,1)
    im8b=.true.
    return
  endif
 
  ! If we're catching bort errors, set a target return location if one doesn't already exist.
 
  if (bort_target_set() == 1) then
    call catch_bort_rtrcpt_c(lunit,iyr,imo,idy,ihr,imi,iret)
    call bort_target_unset
    return
  endif
 
  ! Check the file status.
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: RTRCPT - INPUT BUFR FILE IS CLOSED; IT MUST BE OPEN FOR INPUT')
  if(il>0) call bort('BUFRLIB: RTRCPT - INPUT BUFR FILE IS OPEN FOR OUTPUT; IT MUST BE OPEN FOR INPUT')
  if(im==0) call bort('BUFRLIB: RTRCPT - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE; NONE ARE')
 
  ! Unpack the tank receipt time.
 
  call rtrcptb(mbay(1,lun),iyr,imo,idy,ihr,imi,iret)
 
  return
end subroutine rtrcpt
 
recursive subroutine strcpt(cf,iyr,imo,idy,ihr,imi)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_tnkrcp
 
  implicit none
 
  character, intent(in) :: cf
  character*128 bort_str
  character my_cf
 
  integer, intent(in) :: iyr, imo, idy, ihr, imi
  integer my_iyr, my_imo, my_idy, my_ihr, my_imi, bort_target_set
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(iyr,my_iyr,1)
    call x84(imo,my_imo,1)
    call x84(idy,my_idy,1)
    call x84(ihr,my_ihr,1)
    call x84(imi,my_imi,1)
    call strcpt(cf,my_iyr,my_imo,my_idy,my_ihr,my_imi)
    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_strcpt_c(cf,iyr,imo,idy,ihr,imi)
    call bort_target_unset
    return
  endif
 
  my_cf = cf
  call capit(my_cf)
  if(my_cf /= 'Y' .and. my_cf /= 'N') then
    write(bort_str,'("BUFRLIB: STRCPT - INPUT ARGUMENT IS ",A1,", IT MUST BE EITHER Y, y, N OR n")') cf
    call bort(bort_str)
  endif
 
  ctrt = my_cf
  if(ctrt=='Y') then
    itryr = iyr
    itrmo = imo
    itrdy = idy
    itrhr = ihr
    itrmi = imi
  endif
 
  return
end subroutine strcpt