NetCDF_Supplement.F90 Source File

#include "MAPL_ErrLog.h"
#include "unused_dummy.H"

module pfio_NetCDF_Supplement
   use, intrinsic :: iso_c_binding
   implicit none
   private

   public :: pfio_get_att_string
   public :: pfio_nf90_put_var_string
   public :: pfio_nf90_get_var_string
   public :: pfio_nf90_get_var_string_len

   interface
      function c_f_pfio_get_att_string(ncid, varid, name, string, attlen) &
           & result(stat) bind(C, name='pfio_get_att_string')
         use, intrinsic :: iso_c_binding
         implicit none
         integer :: stat
         integer(kind=C_INT), value, intent(in) :: ncid
         integer(kind=C_INT), value, intent(in) :: varid
         character(kind=C_CHAR), intent(in) :: name(*)
         character(kind=C_CHAR), intent(inout) :: string(*)
         integer(kind=C_INT), intent(inout) :: attlen
      end function c_f_pfio_get_att_string

      function c_f_pfio_get_var_string_len(ncid, varid, str_len_ptr, size) &
           & result(stat) bind(C, name='pfio_get_var_string_len')
         use, intrinsic :: iso_c_binding
         implicit none
         integer :: stat
         integer(kind=C_INT), value, intent(in) :: ncid
         integer(kind=C_INT), value, intent(in) :: varid
         type(c_ptr),         value, intent(in) :: str_len_ptr
         integer(kind=C_INT), value, intent(in) :: size
      end function c_f_pfio_get_var_string_len

      function c_f_pfio_get_var_string(ncid, varid, string_ptr, str_len,  start_ptr, count_ptr) &
           & result(stat) bind(C, name='pfio_get_var_string')
         use, intrinsic :: iso_c_binding
         implicit none
         integer :: stat
         integer(kind=C_INT), value, intent(in) :: ncid
         integer(kind=C_INT), value, intent(in) :: varid
         type(c_ptr), intent(in), value         :: string_ptr
         integer(kind=C_INT), value, intent(in) :: str_len
         type(c_ptr), intent(in), value         :: start_ptr
         type(c_ptr), intent(in), value         :: count_ptr
      end function c_f_pfio_get_var_string

      function c_f_pfio_put_var_string(ncid, varid, string_ptr, str_len, str_size, start_ptr, count_ptr) &
           & result(stat) bind(C, name='pfio_put_var_string')
         use, intrinsic :: iso_c_binding
         implicit none
         integer :: stat
         integer(kind=C_INT), value, intent(in) :: ncid
         integer(kind=C_INT), value, intent(in) :: varid
         type(c_ptr), intent(in), value         :: string_ptr
         integer(kind=C_INT), value, intent(in) :: str_len
         integer(kind=C_INT), value, intent(in) :: str_size
         type(c_ptr), intent(in), value         :: start_ptr
         type(c_ptr), intent(in), value         :: count_ptr
      end function c_f_pfio_put_var_string

   end interface

contains

   function pfio_get_att_string(ncid, varid, name, string) result(status)
      integer :: status
      integer(kind=C_INT), intent(in) :: ncid
      integer(kind=C_INT), intent(in) :: varid
      character(*), intent(in) :: name
      character(:), allocatable, intent(out) :: string

      integer :: name_len
      integer(kind=C_INT),target :: attlen
      character(kind=C_CHAR, len=:), target, allocatable :: c_name
      character(len=512) :: tmp_str

      ! C requires null termination
      name_len = len_trim(name)
      allocate(character(kind=C_CHAR,len=name_len+1) :: c_name)
      c_name(1:name_len) = name(1:name_len)
      c_name(name_len+1:name_len+1) = C_NULL_CHAR
      tmp_str = ''
      ! This c-call would fill tmp_str with the global attribute
      status = c_f_pfio_get_att_string(ncid, varid, c_name, tmp_str, attlen)
      allocate(character(len=attlen) :: string)
      string = trim(tmp_str)
      deallocate(c_name)
   end function pfio_get_att_string

   function pfio_nf90_get_var_string(ncid, varid, string, start, count) result(status)
      integer :: status
      integer(kind=C_INT), intent(in)   :: ncid
      integer(kind=C_INT), intent(in)   :: varid
      character(*), target,intent(inout):: string(:)
      integer, optional,   intent(in)   :: start(:)
      integer, optional,   intent(in)   :: count(:)
      integer, target, allocatable :: start_(:), count_(:)
      integer :: str_len, str_size

      str_len  = len(string(1))
      str_size = size(string)
      if (.not. present(start) .or. .not. present(count)) then
        allocate(start_(1), count_(1))
        start_(1) = 1
        count_(1) = str_size
      else
        start_ = start
        count_ = count
      endif
      status = c_f_pfio_get_var_string(ncid, varid, c_loc(string), str_len,  c_loc(start_), c_loc(count_))
      deallocate(start_, count_)

   end function pfio_nf90_get_var_string

   function pfio_nf90_put_var_string(ncid, varid, string, start, count) result(status)
      integer :: status
      integer(kind=C_INT), intent(in) :: ncid
      integer(kind=C_INT), intent(in) :: varid
      character(*), target,intent(in):: string(:)
      integer, optional,   intent(in) :: start(:)
      integer, optional,   intent(in) :: count(:)
      integer, target, allocatable :: start_(:), count_(:)
      integer :: max_len, str_size, k
      character(len=:),allocatable, target :: string_C(:)

      max_len  = len(string(1)) + 1
      str_size = size(string)
      if (.not. present(start) .or. .not. present(count)) then
        allocate(start_(1), count_(1))
        start_(1) = 1
        count_(1) = str_size
      else
        start_ = start
        count_ = count
      endif

      allocate(character(len=max_len) :: string_C(str_size))
      do k = 1, str_size
        string_C(k) = trim(adjustl(string(k)))//c_null_char
      enddo

      status = c_f_pfio_put_var_string(ncid, varid, c_loc(string_C), max_len, str_size, c_loc(start_), c_loc(count_))
      deallocate(start_, count_)
      deallocate(string_C)
   end function pfio_nf90_put_var_string

   function pfio_nf90_get_var_string_len(ncid, varid, str_len) result(status)
      use netcdf
      integer :: status
      integer, intent(in) :: ncid
      integer, intent(in) :: varid
      integer, intent(out):: str_len
      integer, allocatable  :: dimids(:)
      integer  :: size
      integer, target  :: length

      allocate(dimids(1))
      status = nf90_inquire_variable(ncid,  varid, dimids=dimids)
      status = nf90_inquire_dimension(ncid, dimids(1), len=size)
      status = c_f_pfio_get_var_string_len(ncid, varid, c_loc(length), size)
      str_len = length

   end function pfio_nf90_get_var_string_len

end module pfio_NetCDF_Supplement