bufr_c2f_interface.F90

Go to the documentation of this file.

 
 
module bufr_c2f_interface
 
  use iso_c_binding
 
  implicit none
 
  private
  public :: open_c, close_c, openbf_c, closbf_c
  public :: exitbufr_c, bort_c
  public :: ireadmg_c, ireadsb_c, ireadns_c, openmb_c
  public :: ufbint_c, ufbrep_c, ufbseq_c
  public :: mtinfo_c, bvers_c, status_c, ibfms_c
  public :: get_isc_c, get_link_c, get_itp_c, get_typ_c, get_tag_c, get_jmpb_c
  public :: get_inode_c, get_nval_c, get_val_c, get_inv_c, get_irf_c, readlc_c
  public :: delete_table_data_c
  public :: iupbs01_c, imrkopr_c, istdesc_c, ifxy_c
  public :: igetntbi_c, igettdi_c, stntbi_c
  public :: igetprm_c, isetprm_c, maxout_c, igetmxby_c
  public :: elemdx_c, cadn30_c, strnum_c, uptdd_c, pktdd_c
  public :: nemdefs_c, nemspecs_c, nemtab_c, nemtbb_c, numtbd_c
 
  integer, allocatable, target, save :: isc_f(:), link_f(:), itp_f(:), jmpb_f(:), irf_f(:)
  character(len=10), allocatable, target, save :: tag_f(:)
  character(len=3), allocatable, target, save :: typ_f(:)
 
  contains
 
    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
 
    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(out) :: 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 nemdefs_c(file_unit, mnemonic, unit_c, unit_str_len, desc_c, desc_str_len, iret) &
            bind(c, name='nemdefs_f')
      integer(c_int), value, intent(in) :: file_unit
      character(kind=c_char,len=1), intent(in) :: mnemonic(*)
      character(kind=c_char, len=1), intent(out) :: unit_c(*)
      integer(c_int), value, intent(in) :: unit_str_len
      character(kind=c_char, len=1), intent(out) :: desc_c(*)
      integer(c_int), value, intent(in) :: desc_str_len
      integer(c_int), intent(out) :: iret
 
      character(len=25) :: unit_f
      character(len=55) :: desc_f
 
      ! Get the unit and description strings
      call nemdefs ( file_unit, c_f_string(mnemonic), desc_f, unit_f, iret)
 
      if (iret == 0) then
        ! Copy the unit Fortran string into the resulting C-style string.
        call copy_f_c_str(unit_f, unit_c, min(len(unit_f), unit_str_len))
        ! Copy the descriptor Fortran string into the resulting C-style string.
        call copy_f_c_str(desc_f, desc_c, min(len(desc_f), desc_str_len))
      end if
    end subroutine nemdefs_c
 
    subroutine nemspecs_c(file_unit, mnemonic, mnemonic_idx, scale, reference, bits, iret) &
            bind(c, name='nemspecs_f')
      integer(c_int), value, intent(in) :: file_unit
      character(kind=c_char,len=1), intent(in) :: mnemonic(*)
      integer(c_int), value, intent(in) ::mnemonic_idx
      integer(c_int), intent(out) :: scale
      integer(c_int), intent(out) :: reference
      integer(c_int), intent(out) :: bits
      integer(c_int), intent(out) :: iret
 
      ! Get the scale, reference and bits
      call nemspecs(file_unit, c_f_string(mnemonic), mnemonic_idx, scale, reference, bits, iret)
    end subroutine nemspecs_c
 
    subroutine nemtab_c(lun, mnemonic, descriptor, table_type, table_idx) &
            bind(c, name='nemtab_f')
      integer(c_int), value, intent(in) :: lun
      character(kind=c_char,len=1), intent(in) :: mnemonic(*)
      integer(c_int), intent(out) :: descriptor
      character(kind=c_char,len=1), intent(out) :: table_type(*)
      integer(c_int), intent(out) :: table_idx
 
      character(len=1) :: table_type_f
 
      call nemtab(lun, c_f_string(mnemonic), descriptor, table_type_f, table_idx)
 
      table_type(1)(1:1) = table_type_f(1:1)
    end subroutine nemtab_c
 
    subroutine nemtbb_c(lun, table_idx, unit_str, unit_str_len, scale, reference, bits) &
            bind(c, name='nemtbb_f')
      integer(c_int), intent(in), value :: lun
      integer(c_int), intent(in), value :: table_idx
      character(kind=c_char,len=1), intent(out) :: unit_str(*)
      integer(c_int), intent(in), value :: unit_str_len
      integer(c_int), intent(out) :: scale
      integer(c_int), intent(out) :: reference
      integer(c_int), intent(out) :: bits
 
      character(len=25) :: unit_str_f
 
      ! Get the scale, reference and bits
      call nemtbb( lun, table_idx, unit_str_f, scale, reference, bits)
      call copy_f_c_str(unit_str_f, unit_str, min(len(unit_str_f), unit_str_len))
    end subroutine nemtbb_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_irf_c(irf_ptr, irf_size) bind(C, name='get_irf_f')
      use moda_tables
      type(c_ptr), intent(inout) :: irf_ptr
      integer(c_int), intent(out) :: irf_size
 
      allocate(irf_f(ntab))
      irf_f(1:ntab) = irf(1:ntab)
      irf_size = size(irf_f)
      irf_ptr = c_loc(irf_f(1))
    end subroutine get_irf_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, num_nodes) bind(C, name='get_nval_f')
      use moda_usrint
      integer(c_int), value, intent(in) :: lun
      integer(c_int), intent(out) :: num_nodes
 
      num_nodes = 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 readlc_c(lunit, str_id, output_str, output_str_len) bind(C, name='readlc_f')
      use moda_rlccmn
      integer(c_int), value, intent(in) :: lunit
      character(kind=c_char, len=1), intent(in) :: str_id(*)
      character(kind=c_char, len=1), intent(out) :: output_str(*)
      integer(c_int), intent(in), value :: output_str_len
 
      character(len=120) :: output_str_f
      integer :: output_str_len_f
 
      call readlc(lunit, output_str_f, c_f_string(str_id))
      output_str_len_f = len(trim(output_str_f)) + 1  ! add 1 for the null terminator
      call copy_f_c_str(output_str_f, output_str, min(output_str_len_f, output_str_len))
    end subroutine readlc_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)
      if (allocated(irf_f)) deallocate(irf_f)
    end subroutine delete_table_data_c
 
    function iupbs01_c(bufr, mnemonic) result(ires) bind(C, name='iupbs01_f')
      integer(c_int), intent(in) :: bufr(*)
      character(kind=c_char, len=1), intent(in) :: mnemonic(*)
      integer(c_int) :: ires
      integer :: iupbs01
 
      ires = iupbs01(bufr,c_f_string(mnemonic))
    end function iupbs01_c
 
    function igetprm_c(cprmnm) result(ires) bind(C, name='igetprm_f')
      character(kind=c_char, len=1), intent(in) :: cprmnm(*)
      integer(c_int) :: ires
      integer :: igetprm
 
      ires = igetprm(c_f_string(cprmnm))
    end function igetprm_c
 
    function isetprm_c(cprmnm,ipval) result(ires) bind(C, name='isetprm_f')
      character(kind=c_char, len=1), intent(in) :: cprmnm(*)
      integer(c_int), value, intent(in) :: ipval
      integer(c_int) :: ires
      integer :: isetprm
 
      ires = isetprm(c_f_string(cprmnm),ipval)
    end function isetprm_c
 
    subroutine maxout_c(max0) bind(C, name='maxout_f')
      integer(c_int), value, intent(in) :: max0
 
      call maxout(max0)
    end subroutine maxout_c
 
    function igetmxby_c() result(ires) bind(C, name='igetmxby_f')
      integer(c_int) :: ires
      integer :: igetmxby
 
      ires = igetmxby()
    end function igetmxby_c
 
    subroutine cadn30_c(idn, adn, adn_str_len) bind(C, name='cadn30_f')
      integer(c_int), intent(in), value :: idn, adn_str_len
      character(kind=c_char, len=1), intent(out) :: adn(*)
      character(len=8) :: adn_f
 
      call cadn30(idn, adn_f)
      call copy_f_c_str(adn_f, adn, adn_str_len)
    end subroutine cadn30_c
 
    function igetntbi_c(lun, table_type) result(ires) bind(C, name='igetntbi_f')
      integer(c_int), value, intent(in) :: lun
      character(kind=c_char,len=1), intent(in) :: table_type(*)
      integer(c_int) :: ires
      integer :: igetntbi
      character(len=1) :: table_type_f
 
      table_type_f(1:1) = table_type(1)(1:1)
 
      ires = igetntbi(lun, table_type_f)
    end function igetntbi_c
 
    subroutine elemdx_c(card,lun) bind(C, name='elemdx_f')
      integer(c_int), value, intent(in) :: lun
      character(kind=c_char, len=1), intent(in) :: card(*)
      character(len=80) :: card_f
      integer :: ii
 
      do ii = 1,80
        card_f(ii:ii) = card(1)(ii:ii)
      enddo
      call elemdx(card_f, lun)
    end subroutine elemdx_c
 
    subroutine numtbd_c(lun,idn,nemo,nemo_str_len,tab,iret) bind(C, name='numtbd_f')
      integer(c_int), value, intent(in) :: lun, idn, nemo_str_len
      character(kind=c_char,len=1), intent(out) :: nemo(*), tab(*)
      integer(c_int), intent(out) :: iret
 
      character(len=9) :: nemo_f
      character(len=1) :: tab_f
 
      call numtbd(lun, idn, nemo_f, tab_f, iret)
 
      call copy_f_c_str(nemo_f, nemo, nemo_str_len)
      tab(1)(1:1) = tab_f(1:1)
    end subroutine numtbd_c
 
    function ifxy_c(cfxy) result(ires) bind(C, name='ifxy_f')
      character(kind=c_char, len=1), intent(in) :: cfxy(*)
      integer(c_int) :: ires
      integer :: ifxy
 
      ires = ifxy(c_f_string(cfxy))
    end function ifxy_c
 
    subroutine uptdd_c(id, lun, ient, iret) bind(C, name='uptdd_f')
      integer(c_int), intent(in), value :: id, lun, ient
      integer(c_int), intent(out) :: iret
 
      call uptdd(id, lun, ient, iret)
    end subroutine uptdd_c
 
    function imrkopr_c(nemo) result(ires) bind(C, name='imrkopr_f')
      character(kind=c_char, len=1), intent(in) :: nemo(*)
      integer(c_int) :: ires
      integer :: imrkopr
 
      ires = imrkopr(c_f_string(nemo))
    end function imrkopr_c
 
    function istdesc_c(idn) result(ires) bind(C, name='istdesc_f')
      integer(c_int), intent(in), value :: idn
      integer(c_int) :: ires
      integer :: istdesc
 
      ires = istdesc(idn)
    end function istdesc_c
 
    subroutine ufbseq_c(bufr_unit, c_data, dim_1, dim_2, iret, table_d_mnemonic) bind(C, name='ufbseq_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_d_mnemonic(*)
      real, pointer :: f_data
 
      call c_f_pointer(c_data, f_data)
      call ufbseq(bufr_unit, f_data, dim_1, dim_2, iret, c_f_string(table_d_mnemonic))
    end subroutine ufbseq_c
 
    function ireadns_c(bufr_unit, c_subset, iddate, subset_str_len) result(ires) bind(C, name='ireadns_f')
      integer(c_int), value, intent(in) :: bufr_unit
      character(kind=c_char, len=1), intent(out) :: 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 :: ireadns
 
      ires = ireadns(bufr_unit, f_subset, iddate)
 
      if (ires == 0) then
        call copy_f_c_str(f_subset, c_subset, subset_str_len)
      end if
    end function ireadns_c
 
    function ibfms_c(r8val) result(ires) bind(C, name='ibfms_f')
      real(c_double), intent(in), value :: r8val
      integer(c_int) :: ires
      integer :: ibfms
 
      ires = ibfms(r8val)
    end function ibfms_c
 
    subroutine strnum_c(str,num,iret) bind(C, name='strnum_f')
      character(kind=c_char, len=1), intent(in) :: str(*)
      integer(c_int), intent(out) :: num, iret
 
      call strnum(c_f_string(str), num, iret)
    end subroutine strnum_c
 
    subroutine stntbi_c(n,lun,numb,nemo,celsq) bind(C, name='stntbi_f')
      integer(c_int), intent(in), value :: n, lun
      character(kind=c_char, len=1), intent(in) :: numb(*), nemo(*), celsq(*)
      character(len=6) :: numb_f
      character(len=8) :: nemo_f
      character(len=55) :: celsq_f
      integer :: ii
 
      do ii = 1,6
        numb_f(ii:ii) = numb(1)(ii:ii)
      enddo
      do ii = 1,8
        nemo_f(ii:ii) = nemo(1)(ii:ii)
      enddo
      do ii = 1,55
        celsq_f(ii:ii) = celsq(1)(ii:ii)
      enddo
      call stntbi(n, lun, numb_f, nemo_f, celsq_f)
    end subroutine stntbi_c
 
    function igettdi_c(iflag) result(ires) bind(C, name='igettdi_f')
      integer(c_int), intent(in), value :: iflag
      integer(c_int) :: ires
      integer :: igettdi
 
      ires = igettdi(iflag)
    end function igettdi_c
 
    subroutine pktdd_c(id, lun, idn, iret) bind(C, name='pktdd_f')
      integer(c_int), intent(in), value :: id, lun, idn
      integer(c_int), intent(out) :: iret
 
      call pktdd(id, lun, idn, iret)
    end subroutine pktdd_c
 
    subroutine bort_c(errstr) bind(C, name='bort_f')
      character(kind=c_char, len=1), intent(in) :: errstr(*)
 
      call bort(c_f_string(errstr))
    end subroutine bort_c
 
    subroutine openmb_c(bufr_unit, c_subset, iddate) bind(C, name='openmb_f')
      integer(c_int), value, intent(in) :: bufr_unit, iddate
      character(kind=c_char, len=1), intent(in) :: c_subset(*)
 
      call openmb(bufr_unit, c_f_string(c_subset), iddate)
    end subroutine openmb_c
 
    subroutine bvers_c(cverstr, cverstr_len) bind(C, name='bvers_f')
      character(kind=c_char, len=1), intent(out) :: cverstr(*)
      integer(c_int), value, intent(in) :: cverstr_len
      character(len=10) :: f_cverstr
 
      call bvers(f_cverstr)
      call copy_f_c_str(f_cverstr, cverstr, cverstr_len)
    end subroutine bvers_c
 
    subroutine cmpmsg_c(cf) bind(C, name='cmpmsg_f')
      character(kind=c_char, len=1), intent(in) :: cf(*)
 
      call cmpmsg(c_f_string(cf))
    end subroutine cmpmsg_c
 
end module bufr_c2f_interface