bufr_interface.f90

Go to the documentation of this file.

module bufr_c_interface_mod

  use iso_c_binding

  implicit none

  private
  public :: open_c, close_c
  public :: openbf_c, closbf_c
  public :: exitbufr_c
  public :: ireadmg_c
  public :: ireadsb_c
  public :: ufbint_c
  public :: ufbrep_c
  public :: mtinfo_c

  integer, allocatable, target, save :: isc_f(:)
  integer, allocatable, target, save :: link_f(:)
  integer, allocatable, target, save :: itp_f(:)
  integer, allocatable, target, save :: jmpb_f(:)
  character(len=10), allocatable, target, save :: tag_f(:)
  character(len=3), allocatable, target, save :: typ_f(:)

contains

!Private

function c_f_string(c_str) result(f_str)
  character(kind=c_char,len=1), intent(in) :: c_str(*)
  character(len=:), allocatable :: f_str
  integer :: nchars

  nchars = 1
  do while (c_str(nchars) /= c_null_char)
      nchars = nchars + 1
  end do
  nchars = nchars - 1

  allocate(character(len=nchars) :: f_str)
  f_str = transfer(c_str(1:nchars), f_str)
end function c_f_string


subroutine copy_f_c_str(f_str, c_str, c_str_len)
  character(len=*), target, intent(in) :: f_str
  character(kind=c_char, len=1), intent(inout) :: c_str(*)
  integer, intent(in) :: c_str_len
  integer :: max_str_len

  if (c_str_len /= 0) then
    max_str_len = c_str_len
    c_str(1)(1:max_str_len) = f_str(1:max_str_len)
    c_str(1)(max_str_len:max_str_len) = c_null_char
  end if
end subroutine copy_f_c_str

!Public

subroutine open_c(lunit, filepath) bind(C, name='open_f')
  integer(c_int), value, intent(in) :: lunit
  character(kind=c_char, len=1) :: filepath

  open(lunit, file=c_f_string(filepath))
end subroutine open_c


subroutine close_c(lunit) bind(C, name='close_f')
  integer(c_int), value, intent(in) :: lunit

  close(unit=lunit)
end subroutine close_c


subroutine openbf_c(bufr_unit, cio, table_file_id) bind(C, name='openbf_f')
  integer(c_int), value, intent(in) :: bufr_unit
  character(kind=c_char, len=1), intent(in) :: cio
  integer(c_int), value, intent(in) :: table_file_id

  call openbf(bufr_unit, c_f_string(cio), table_file_id)
end subroutine openbf_c


subroutine closbf_c(bufr_unit) bind(C, name='closbf_f')
  integer(c_int), value, intent(in) :: bufr_unit

  call closbf(bufr_unit)
end subroutine closbf_c


subroutine exitbufr_c() bind(C, name='exitbufr_f')
  call exitbufr()
end subroutine exitbufr_c


function ireadmg_c(bufr_unit, c_subset, iddate, subset_str_len) result(ires) bind(C, name='ireadmg_f')
  integer(c_int), value, intent(in) :: bufr_unit
  character(kind=c_char, len=1), intent(inout) :: c_subset(*)
  integer(c_int), intent(out) :: iddate
  integer(c_int), value, intent(in) :: subset_str_len
  integer(c_int) :: ires
  character(len=25) :: f_subset
  integer :: ireadmg

  ires = ireadmg(bufr_unit, f_subset, iddate)

  if (ires == 0) then
    call copy_f_c_str(f_subset, c_subset, int(subset_str_len))
  end if
end function ireadmg_c


function ireadsb_c(bufr_unit) result(ires) bind(C, name='ireadsb_f')
  integer(c_int), value, intent(in) :: bufr_unit
  integer(c_int) :: ires
  integer :: ireadsb

  ires = ireadsb(bufr_unit)
end function ireadsb_c


subroutine ufbint_c(bufr_unit, c_data, dim_1, dim_2, iret, table_b_mnemonic) bind(C, name='ufbint_f')
  integer(c_int), value, intent(in) :: bufr_unit
  type(c_ptr), intent(inout) ::  c_data
  integer(c_int), value, intent(in) :: dim_1, dim_2
  integer(c_int), intent(out) :: iret
  character(kind=c_char, len=1), intent(in) :: table_b_mnemonic
  real, pointer :: f_data

  call c_f_pointer(c_data, f_data)
  call ufbint(bufr_unit, f_data, dim_1, dim_2, iret, c_f_string(table_b_mnemonic))
end subroutine ufbint_c


subroutine ufbrep_c(bufr_unit, c_data, dim_1, dim_2, iret, table_b_mnemonic) bind(C, name='ufbrep_f')
  integer(c_int), value, intent(in) :: bufr_unit
  type(c_ptr), intent(inout) :: c_data
  integer(c_int), value, intent(in) :: dim_1, dim_2
  integer(c_int), intent(out) :: iret
  character(kind=c_char, len=1), intent(in) :: table_b_mnemonic
  real, pointer :: f_data

  call c_f_pointer(c_data, f_data)
  call ufbrep(bufr_unit, f_data, dim_1, dim_2, iret, c_f_string(table_b_mnemonic))
end subroutine ufbrep_c


subroutine mtinfo_c(path, file_unit_1, file_unit_2) bind(C, name='mtinfo_f')
  character(kind=c_char, len=1), intent(in) :: path
  integer(c_int), value, intent(in) :: file_unit_1
  integer(c_int), value, intent(in) :: file_unit_2

  call mtinfo(c_f_string(path), file_unit_1, file_unit_2)
end subroutine mtinfo_c


! ----------------------------------------------------------------------
! ----------------------------------------------------------------------

subroutine status_c(file_unit, lun, il, im) bind(C, name='status_f')
  integer(c_int), value, intent(in) :: file_unit
  integer(c_int), intent(out) :: lun
  integer(c_int), intent(out) :: il
  integer(c_int), intent(out) :: im

  call status(file_unit, lun, il, im)
end subroutine status_c


subroutine get_isc_c(isc_ptr, isc_size) bind(C, name='get_isc_f')
  use moda_tables
  type(c_ptr), intent(inout) :: isc_ptr
  integer(c_int), intent(out) :: isc_size

  allocate(isc_f(ntab))
  isc_f(1:ntab) = isc(1:ntab)
  isc_size = size(isc_f)
  isc_ptr = c_loc(isc_f(1))
end subroutine get_isc_c


subroutine get_link_c(link_ptr, link_size) bind(C, name='get_link_f')
  use moda_tables
  type(c_ptr), intent(inout) :: link_ptr
  integer(c_int), intent(out) :: link_size

  allocate(link_f(ntab))
  link_f(1:ntab) = link(1:ntab)
  link_size = size(link_f)
  link_ptr = c_loc(link_f(1))
end subroutine get_link_c


subroutine get_itp_c(itp_ptr, itp_size) bind(C, name='get_itp_f')
  use moda_tables
  type(c_ptr), intent(inout) :: itp_ptr
  integer(c_int), intent(out) :: itp_size

  allocate(itp_f(ntab))
  itp_f(1:ntab) = itp(1:ntab)
  itp_size = size(itp_f)
  itp_ptr = c_loc(itp_f(1))
end subroutine get_itp_c


subroutine get_typ_c(typ_ptr, typ_len, mem_size) bind(C, name='get_typ_f')
  use moda_tables
  type(c_ptr), intent(inout) :: typ_ptr
  integer(c_int), intent(out) :: typ_len
  integer(c_int), intent(out) :: mem_size

  allocate(typ_f(ntab))
  typ_f(1:ntab) = typ(1:ntab)
  typ_len = len(typ(1))
  mem_size = size(typ_f)
  typ_ptr = c_loc(typ_f(1))
end subroutine get_typ_c


subroutine get_tag_c(tag_ptr, tag_len, mem_size) bind(C, name='get_tag_f')
  use moda_tables
  type(c_ptr), intent(inout) :: tag_ptr
  integer(c_int), intent(out) :: tag_len
  integer(c_int), intent(out) :: mem_size

  allocate(tag_f(ntab))
  tag_f(1:ntab) = tag(1:ntab)
  tag_len = len(tag(1))
  mem_size = size(tag_f)
  tag_ptr = c_loc(tag_f(1))
end subroutine get_tag_c


subroutine get_jmpb_c(jmpb_ptr, jmpb_size) bind(C, name='get_jmpb_f')
  use moda_tables
  type(c_ptr), intent(inout) :: jmpb_ptr
  integer(c_int), intent(out) :: jmpb_size

  allocate(jmpb_f(ntab))
  jmpb_f(1:ntab) = jmpb(1:ntab)
  jmpb_size = size(jmpb_f)
  jmpb_ptr = c_loc(jmpb_f(1))
end subroutine get_jmpb_c


subroutine get_inode_c(lun, start_node) bind(C, name='get_inode_f')
  use moda_msgcwd
  integer(c_int), value, intent(in) :: lun
  integer(c_int), intent(out) :: start_node

  start_node = inode(lun)
end subroutine get_inode_c


subroutine get_nval_c(lun, numNodes) bind(C, name='get_nval_f')
  use moda_usrint
  integer(c_int), value, intent(in) :: lun
  integer(c_int), intent(out) :: numnodes

  numnodes = nval(lun)
end subroutine get_nval_c


subroutine get_val_c(lun, val_ptr, val_size) bind(C, name='get_val_f')
  use moda_usrint
  integer(c_int), value, intent(in) :: lun
  type(c_ptr), intent(inout) :: val_ptr
  integer(c_int), intent(out) :: val_size

  val_size = size(val(:, lun))
  val_ptr = c_loc(val(1, lun))
end subroutine get_val_c


subroutine get_inv_c(lun, inv_ptr, inv_size) bind(C, name='get_inv_f')
  use moda_usrint
  integer(c_int), value, intent(in) :: lun
  type(c_ptr), intent(inout) :: inv_ptr
  integer(c_int), intent(out) :: inv_size

  inv_size = size(inv(:, lun))
  inv_ptr = c_loc(inv(1, lun))
end subroutine get_inv_c


subroutine delete_table_data_c() bind(C, name='delete_table_data_f')
  if (allocated(isc_f)) deallocate(isc_f)
  if (allocated(link_f)) deallocate(link_f)
  if (allocated(itp_f)) deallocate(itp_f)
  if (allocated(typ_f)) deallocate(typ_f)
  if (allocated(tag_f)) deallocate(tag_f)
  if (allocated(jmpb_f)) deallocate(jmpb_f)
end subroutine delete_table_data_c

end module bufr_c_interface_mod