cftbvs.F90

Go to the documentation of this file.

 
 
recursive real*8 function pkftbv(nbits,ibit) result(r8val)
 
  use modv_vars, only: im8b, bmiss
 
  implicit none
 
  integer, intent(in) :: nbits, ibit
  integer my_nbits, my_ibit
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
    call x84(nbits,my_nbits,1)
    call x84(ibit,my_ibit,1)
    r8val=pkftbv(my_nbits,my_ibit)
    im8b=.true.
    return
  endif
 
  if((nbits<=0).or.(ibit<=0).or.(ibit>nbits)) then
    r8val = bmiss
  else
    r8val = (2.)**(nbits-ibit)
  endif
 
  return
end function pkftbv
 
recursive subroutine upftbv(lunit,nemo,val,mxib,ibit,nib)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_tababd
 
  implicit none
 
  integer, intent(in) :: lunit, mxib
  integer, intent(out) :: ibit(*), nib
  integer my_lunit, my_mxib, lun, il, im, idn, i, n, nbits, iersn, lcn, bort_target_set
 
  character*(*), intent(in) :: nemo
  character*128 bort_str
  character*12 cnemo
  character tab
 
  real*8, intent(in) :: val
  real*8 r8val, r82i
 
  ! Check for I8 integers.
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call x84(mxib,my_mxib,1)
    call upftbv(my_lunit,nemo,val,my_mxib*2,ibit,nib)
    if (nib>0 .and. nib<=my_mxib*2) call x48(ibit(1),ibit(1),nib)
    call x48(nib,nib,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(nemo,cnemo,lcn)
    call catch_bort_upftbv_c(lunit,cnemo,lcn,val,ibit,mxib,nib)
    call bort_target_unset
    return
  endif
 
  nib = 0
 
  ! Perform some sanity checks.
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: UPFTBV - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
 
  call nemtab(lun,nemo,idn,tab,n)
  if(n==0) then
    write(bort_str,'("BUFRLIB: UPFTBV - MNEMONIC ",A," NOT FOUND IN TABLE B")') nemo
    call bort(bort_str)
  endif
  if(tabb(n,lun)(71:74)/='FLAG') then
    write(bort_str,'("BUFRLIB: UPFTBV - MNEMONIC ",A," IS NOT A FLAG TABLE")') nemo
    call bort(bort_str)
  endif
 
  ! Figure out which bits are set.
 
  r8val = val
  call strnum(tabb(n,lun)(110:112),nbits,iersn)
  do i=(nbits-1),0,-1
    r82i = (2.)**i
    if(abs(r8val-r82i)<(0.005)) then
      nib = nib + 1
      if(nib>mxib) call bort('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW')
      ibit(nib) = nbits-i
      return
    elseif(r82i<r8val) then
      nib = nib + 1
      if(nib>mxib) call bort('BUFRLIB: UPFTBV - IBIT ARRAY OVERFLOW')
      ibit(nib) = nbits-i
      r8val = r8val - r82i
    endif
  enddo
 
  return
end subroutine upftbv
 
recursive subroutine getcfmng ( lunit, nemoi, ivali, nemod, ivald, cmeang, lnmng, iret )
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  use moda_tababd
  use moda_tablef
 
  implicit none
 
  integer, intent(in) :: lunit, ivali, ivald
  integer, intent(out) :: lnmng, iret
  integer ifxyd(10), my_lunit, my_ivali, my_ivald, lun, il, im, itmp, ii, ifxyi, lcmg, n, ntg, iret2, ierbd, ifxy, ireadmt, &
    lcni, lcnd, lcmgc, bort_target_set
 
  character*(*), intent(in) :: nemoi, nemod
  character*(*), intent(out) :: cmeang
  character*128 bort_str
  character*9 cnemoi, cnemod
  character*8 nemo, my_nemoi, my_nemod
  character tab
  character*(:), allocatable :: cmeang_c
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call x84(ivali,my_ivali,1)
    call x84(ivald,my_ivald,1)
    call getcfmng(my_lunit,nemoi,my_ivali,nemod,my_ivald,cmeang,lnmng,iret)
    call x48(lnmng,lnmng,1)
    call x48(iret,iret,1)
    im8b=.true.
    return
  endif
 
  cmeang = ' '
  lcmg = len( cmeang )
 
  ! 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(nemoi,cnemoi,lcni)
    call strsuc(nemod,cnemod,lcnd)
    lcmgc = lcmg + 1  ! Allow extra byte in cmeang_c for the trailing null in C
    allocate(character*(lcmgc) :: cmeang_c)
    call catch_bort_getcfmng_c(lunit,cnemoi,lcni,ivali,cnemod,lcnd,ivald,cmeang_c,lcmgc,lnmng,iret)
    cmeang(1:lnmng) = cmeang_c(1:lnmng)
    deallocate(cmeang_c)
    call bort_target_unset
    return
  endif
 
  call status ( lunit, lun, il, im )
  if ( il == 0 ) call bort('BUFRLIB: GETCFMNG - INPUT BUFR FILE IS CLOSED, IT MUST BE OPEN FOR INPUT')
  if ( il > 0 ) call bort('BUFRLIB: GETCFMNG - INPUT BUFR FILE IS OPEN FOR OUTPUT, IT MUST BE OPEN FOR INPUT')
  if ( im == 0 ) call bort('BUFRLIB: GETCFMNG - A MESSAGE MUST BE OPEN IN INPUT BUFR FILE, NONE ARE')
 
  ! Make sure the appropriate code/flag information has already been read into internal memory.
 
  if ( cdmf /= 'Y' ) call bort('BUFRLIB: GETCFMNG - TO USE THIS SUBROUTINE, MUST '// &
    'FIRST CALL SUBROUTINE CODFLG WITH INPUT ARGUMENT SET TO Y')
 
  itmp = ireadmt( lun )
 
  ! Check the validity of the input mnemonic(s).  Include special handling for originating centers, originating subcenters, data
  ! types and data subtypes, since those can be reported in Section 1 of a BUFR message as well as in Section 3, so if a user
  ! requests those mnemonics we can't necessarily assume they came from within Section 3.
 
  my_nemoi = '        '
  do ii = 1, min( 8, len( nemoi ) )
    my_nemoi(ii:ii) = nemoi(ii:ii)
  end do
  my_nemod = '        '
  do ii = 1, min( 8, len( nemod ) )
    my_nemod(ii:ii) = nemod(ii:ii)
  end do
  if ( my_nemoi(1:4) == 'GSES' ) then
    if ( ( my_nemod(1:6) == 'GCLONG' ) .or. ( my_nemod(1:4) == 'OGCE' ) .or. ( my_nemod(1:5) == 'ORIGC' ) ) then
      ifxyi = ifxy( '001034' )
      ifxyd(1) = ifxy( '001035' )
    else
      lnmng = min( 24, lcmg )
      if ( lnmng == 24 ) then
        iret = 3
        cmeang(1:24) = 'GCLONG  OGCE    ORIGC   '
      else
        iret = -1
      end if
      return
    end if
  else if ( my_nemoi(1:6) == 'GCLONG' ) then
    ifxyi = ifxy( '001031' )
    ifxyd(1) = (-1)
  else if ( my_nemoi(1:4) == 'OGCE' ) then
    ifxyi = ifxy( '001033' )
    ifxyd(1) = (-1)
  else if ( my_nemoi(1:5) == 'ORIGC' ) then
    ifxyi = ifxy( '001035' )
    ifxyd(1) = (-1)
  else if ( ( my_nemoi(1:7) == 'TABLASS' ) .or. ( my_nemoi(1:7) == 'TABLASL' ) ) then
    if ( ( my_nemod(1:6) == 'TABLAT' ) ) then
      if ( my_nemoi(1:7) == 'TABLASS' ) then
        ifxyi = ifxy( '055021' )
      else
        ifxyi = ifxy( '055022' )
      endif
      ifxyd(1) = ifxy( '055020' )
    else
      lnmng = min( 8, lcmg )
      if ( lnmng == 8 ) then
        iret = 1
        cmeang(1:8) = 'TABLAT  '
      else
        iret = -1
      end if
      return
    end if
  else if ( my_nemoi(1:6) == 'TABLAT' ) then
    ifxyi = ifxy( '055020' )
    ifxyd(1) = (-1)
  else
    call parstr ( my_nemoi, nemo, 1, ntg, ' ', .true. )
    call nemtab ( lun, nemo, ifxyi, tab, n )
    if ( ( n == 0 ) .or. ( tab /= 'B' ) ) then
      write(bort_str,'("BUFRLIB: GETCFMNG - MNEMONIC ",A," NOT FOUND IN TABLE B")') nemo
      call bort(bort_str)
    endif
    if ( ( tabb( n, lun )(71:74) /= 'CODE' ) .and. ( tabb( n, lun )(71:74) /= 'FLAG' ) ) then
      write(bort_str,'("BUFRLIB: GETCFMNG - MNEMONIC ",A," IS NOT A CODE OR FLAG TABLE")') nemo
      call bort(bort_str)
    endif
    if ( my_nemod(1:1) /= ' ' ) then
      call parstr ( my_nemod, nemo, 1, ntg, ' ', .true. )
      call nemtab ( lun, nemo, ifxyd(1), tab, n )
      if ( ( n == 0 ) .or. ( tab /= 'B' ) ) then
        write(bort_str,'("BUFRLIB: GETCFMNG - MNEMONIC ",A," NOT FOUND IN TABLE B")') nemo
        call bort(bort_str)
      endif
      if ( ( tabb( n, lun )(71:74) /= 'CODE' ) .and. ( tabb( n, lun )(71:74) /= 'FLAG' ) ) then
        write(bort_str,'("BUFRLIB: GETCFMNG - MNEMONIC ",A," IS NOT A CODE OR FLAG TABLE")') nemo
        call bort(bort_str)
      endif
    else
      ifxyd(1) = (-1)
    end if
  end if
 
  ! Search the internal table for the requested meaning.
 
  call srchtbf_c ( ifxyi, ivali, ifxyd(1), 10, ivald, cmeang, lcmg, lnmng, iret )
  if ( iret <= 0 ) return
 
  ! The meaning of this value is dependent on the value of another mnemonic in the report.
 
  iret2 = iret
  lnmng = 0
  iret = 0
  do ii = 1, iret2
    call numtbd ( lun, ifxyd(ii), nemo, tab, ierbd )
    if ( ( ierbd > 0 ) .and. ( tab == 'B' ) .and. ( lcmg >= ( lnmng + 8 ) ) ) then
      iret = iret + 1
      cmeang(lnmng+1:lnmng+8) = nemo
      lnmng = lnmng + 8
    end if
  end do
  if ( iret == 0 ) iret = -1
 
  return
end subroutine getcfmng
 
recursive subroutine ufbqcd(lunit,nemo,iqcd)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(in) :: lunit
  integer, intent(out) :: iqcd
  integer my_lunit, lun, il, im, idn, iret, lcn, bort_target_set
 
  character*(*), intent(in) :: nemo
  character*128 bort_str
  character*12 cnemo
  character*6 fxy, adn30
  character tab
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call ufbqcd(my_lunit,nemo,iqcd)
    call x48(iqcd,iqcd,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(nemo,cnemo,lcn)
    call catch_bort_ufbqcd_c(lunit,cnemo,iqcd,lcn)
    call bort_target_unset
    return
  endif
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: UFBQCD - BUFR FILE IS CLOSED, IT MUST BE OPEN')
 
  call nemtab(lun,nemo,idn,tab,iret)
  if(tab/='D') then
    write(bort_str,'("BUFRLIB: UFBQCD - INPUT MNEMONIC ",A," NOT DEFINED AS A SEQUENCE DESCRIPTOR IN BUFR TABLE")') nemo
    call bort(bort_str)
  endif
 
  fxy = adn30(idn,6)
  if(fxy(2:3)/='63') then
    write(bort_str,'("BUFRLIB: UFBQCD - BUFR TABLE SEQ. DESCRIPTOR '// &
      'ASSOC. WITH INPUT MNEMONIC ",A," HAS INVALID CATEGORY ",A," - CATEGORY MUST BE 63")') nemo, fxy(2:3)
    call bort(bort_str)
  endif
  read(fxy(4:6),'(I3)') iqcd
 
  return
end subroutine ufbqcd
 
recursive subroutine ufbqcp(lunit,iqcp,nemo)
 
  use bufrlib
 
  use modv_vars, only: im8b
 
  implicit none
 
  integer, intent(in) :: lunit, iqcp
  integer my_lunit, my_iqcp, lun, il, im, idn, iret, ifxy, lnm, ncn, bort_target_set
 
  character*(*), intent(out) :: nemo
  character*9 cnemo
  character tab
 
  ! Check for I8 integers
 
  if(im8b) then
    im8b=.false.
    call x84(lunit,my_lunit,1)
    call x84(iqcp,my_iqcp,1)
    call ufbqcp(my_lunit,my_iqcp,nemo)
    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_ufbqcp_c(lunit,iqcp,cnemo,len(cnemo),ncn)
    nemo = ' '
    lnm = min(len(nemo),ncn)
    nemo(1:lnm) = cnemo(1:lnm)
    call bort_target_unset
    return
  endif
 
  call status(lunit,lun,il,im)
  if(il==0) call bort('BUFRLIB: UFBQCP - BUFR FILE IS CLOSED, IT MUST BE OPEN')
 
  idn = ifxy('363000')+iqcp
  call numtab(lun,idn,nemo,tab,iret)
 
  return
end subroutine ufbqcp