pFIO_Utilities.F90 Source File

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

module pFIO_UtilitiesMod
   use, intrinsic :: iso_c_binding, only: c_sizeof 
   use, intrinsic :: iso_fortran_env, only: INT32,REAL32,INT64,REAL64
   use pFIO_ConstantsMod
   use MAPL_ExceptionHandling
   implicit none
   private

   public :: serialize_buffer_length
   public :: serialize_intrinsic
   public :: deserialize_intrinsic
   public :: nearlyEqual
   public :: word_size
   public :: i_to_string

   interface serialize_buffer_length
      module procedure serialize_buffer_length_string
      module procedure serialize_buffer_length_int32_0d
      module procedure serialize_buffer_length_int32_1d
      module procedure serialize_buffer_length_int64_0d
      module procedure serialize_buffer_length_int64_1d
      module procedure serialize_buffer_length_real32_0d
      module procedure serialize_buffer_length_real32_1d
      module procedure serialize_buffer_length_real64_0d
      module procedure serialize_buffer_length_real64_1d
      module procedure serialize_buffer_length_logical_0d
      module procedure serialize_buffer_length_logical_1d
   end interface serialize_buffer_length

   interface serialize_intrinsic
      module procedure serialize_string
      module procedure serialize_int32_0d
      module procedure serialize_int32_1d
      module procedure serialize_int64_0d
      module procedure serialize_int64_1d
      module procedure serialize_real32_0d
      module procedure serialize_real32_1d
      module procedure serialize_real64_0d
      module procedure serialize_real64_1d
      module procedure serialize_logical_0d
      module procedure serialize_logical_1d
   end interface serialize_intrinsic

   interface deserialize_intrinsic
      module procedure deserialize_string
      module procedure deserialize_int32_0d
      module procedure deserialize_int32_1d
      module procedure deserialize_int64_0d
      module procedure deserialize_int64_1d
      module procedure deserialize_real32_0d
      module procedure deserialize_real32_1d
      module procedure deserialize_real64_0d
      module procedure deserialize_real64_1d
      module procedure deserialize_logical_0d
      module procedure deserialize_logical_1d
   end interface deserialize_intrinsic

   interface nearlyEqual
     module procedure nearlyEqual_real32
     module procedure nearlyEqual_real64
   end interface nearlyEqual

   integer, parameter :: CHARS_PER_INT32 = 4

contains

!-- length

   integer function serialize_buffer_length_string(str, rc) result(length)
      character(len=*),  intent(in) :: str
      integer, optional, intent(out) :: rc

      integer :: n

      n = len(str)
      ! two words in header
      length = 1 + 1 + (1 + (n-1)/CHARS_PER_INT32)

      _RETURN(_SUCCESS)
   end function serialize_buffer_length_string

   integer function serialize_buffer_length_int32_0d(scalar, rc) result(length)
      integer(kind=INT32), intent(in) :: scalar
      integer, optional, intent(out) :: rc

      length = 1
      _RETURN(_SUCCESS)
      _UNUSED_DUMMY(scalar)
   end function serialize_buffer_length_int32_0d

   integer function serialize_buffer_length_int32_1d(array, rc) result(length)
      integer(kind=INT32), intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      length = 1 + size(array)
      _RETURN(_SUCCESS)
   end function serialize_buffer_length_int32_1d

   integer function serialize_buffer_length_int64_0d(scalar, rc) result(length)
      integer(kind=INT64), intent(in) :: scalar
      integer, optional, intent(out) :: rc

      length = 2
      _RETURN(_SUCCESS)
      _UNUSED_DUMMY(scalar)
   end function serialize_buffer_length_int64_0d

   integer function serialize_buffer_length_int64_1d(array, rc) result(length)
      integer(kind=INT64), intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      length = 1 + size(array)*word_size(pFIO_INT64)
      _RETURN(_SUCCESS)
   end function serialize_buffer_length_int64_1d

   integer function serialize_buffer_length_real32_0d(scalar,rc) result(length)
      real(kind=REAL32), intent(in) :: scalar
      integer, optional, intent(out) :: rc

      length = word_size(pFIO_REAL32)
      _RETURN(_SUCCESS)
      _UNUSED_DUMMY(scalar)
   end function serialize_buffer_length_real32_0d

   integer function serialize_buffer_length_real32_1d(array, rc) result(length)
      real(kind=REAL32), intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      length = 1 + size(array)*word_size(pFIO_REAL32)

      _RETURN(_SUCCESS)
   end function serialize_buffer_length_real32_1d

   integer function serialize_buffer_length_real64_0d(scalar, rc) result(length)
      real(kind=REAL64), intent(in) :: scalar
      integer, optional, intent(out) :: rc

      length = word_size(pFIO_REAL64)
      _RETURN(_SUCCESS)
      _UNUSED_DUMMY(scalar)
   end function serialize_buffer_length_real64_0d


   integer function serialize_buffer_length_real64_1d(array, rc) result(length)
      real(kind=REAL64), intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      length = 1 + size(array)*word_size(pFIO_REAL64)
      _RETURN(_SUCCESS)
   end function serialize_buffer_length_real64_1d

   integer function serialize_buffer_length_logical_0d(scalar, rc) result(length)
      logical, intent(in) :: scalar
      integer, optional, intent(out) :: rc

      length = word_size(pFIO_LOGICAL)
      _RETURN(_SUCCESS)
      _UNUSED_DUMMY(scalar)
   end function serialize_buffer_length_logical_0d


   integer function serialize_buffer_length_logical_1d(array, rc) result(length)
      logical, intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      length = 1 + size(array)*word_size(pFIO_LOGICAL)
      _RETURN(_SUCCESS)
   end function serialize_buffer_length_logical_1d

!-> serializing

   function serialize_string(str, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      character(len=*), intent(in) :: str
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: str_len

      str_len = len(str)
      buffer = [0, str_len, transfer(str,[1])]
      buffer(1) = size(buffer)

      _RETURN(_SUCCESS)
   end function serialize_string


   function serialize_int32_0d(scalar, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      integer(kind=INT32), intent(in) :: scalar
      integer, optional, intent(out) :: rc

      buffer = [scalar]

      _RETURN(_SUCCESS)
   end function serialize_int32_0d


   function serialize_int32_1d(array, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      integer(kind=INT32), intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: n

      n = size(array)
      buffer = [n+1, array]
      _RETURN(_SUCCESS)
   end function serialize_int32_1d

   function serialize_int64_0d(scalar, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      integer(kind=INT64), intent(in) :: scalar
      integer, optional, intent(out) :: rc

      buffer = [transfer(scalar,[1])]

      _RETURN(_SUCCESS)
   end function serialize_int64_0d

   function serialize_int64_1d(array, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      integer(kind=INT64), intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: n

      n = size(array)*word_size(pFIO_INT64)
      buffer = [n+1, transfer(array,[1])]

      _RETURN(_SUCCESS)
   end function serialize_int64_1d

   function serialize_real32_0d(scalar, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      real(kind=REAL32), intent(in) :: scalar
      integer, optional, intent(out) :: rc

      buffer = [transfer(scalar,1)]

      _RETURN(_SUCCESS)
   end function serialize_real32_0d


   function serialize_real32_1d(array, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      real(kind=REAL32), intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: n

      n = size(array)*word_size(pFIO_REAL32)
      buffer = [n+1, transfer(array,[1])]

      _RETURN(_SUCCESS)
   end function serialize_real32_1d

   function serialize_real64_0d(scalar, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      real(kind=REAL64), intent(in) :: scalar
      integer, optional, intent(out) :: rc

      buffer = [transfer(scalar,[1])]

      _RETURN(_SUCCESS)
   end function serialize_real64_0d


   function serialize_real64_1d(array, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      real(kind=REAL64), intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: n

      n = size(array)*word_size(pFIO_REAL64)
      buffer = [n+1, transfer(array,[1])]

      _RETURN(_SUCCESS)
   end function serialize_real64_1d

   function serialize_logical_0d(scalar, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      logical, intent(in) :: scalar
      integer, optional, intent(out) :: rc
     
      allocate(buffer(1), source = 0)
      if(scalar) buffer(1) = 1

      _RETURN(_SUCCESS)
   end function serialize_logical_0d


   function serialize_logical_1d(array, rc) result(buffer)
      integer(kind=INT32), allocatable :: buffer(:)
      logical, intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      integer, allocatable :: itmp(:)
      integer(kind=INT32) :: n

      n = size(array)*word_size(pFIO_LOGICAL)
      allocate(itmp(n), source = 0)
      where(array)
         itmp = 1
      endwhere
      buffer = [n+1, itmp]

      _RETURN(_SUCCESS)
   end function serialize_logical_1d

!-> deserializing

   subroutine deserialize_string(buffer, str, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      character(len=:), allocatable :: str
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: buf_size, str_len
      
      _ASSERT(size(buffer) >= 2, "wrong buffer")      

      buf_size = buffer(1)
      str_len = buffer(2)
      allocate(character(str_len) :: str)
      str = transfer(buffer(3:buf_size), str)

      _RETURN(_SUCCESS)
   end subroutine deserialize_string

   
   subroutine deserialize_int32_0d(buffer, scalar, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      integer(kind=INT32), intent(out) :: scalar
      integer, optional, intent(out) :: rc

      _ASSERT(size(buffer) >= 1, "wrong buffer")      
      scalar = buffer(1)

      _RETURN(_SUCCESS)
   end subroutine deserialize_int32_0d


   subroutine deserialize_int32_1d(buffer, array, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      integer(kind=INT32), allocatable, intent(out) :: array(:)
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: n

      _ASSERT(size(buffer) >= 1, "wrong buffer")      

      n = buffer(1)
      array = buffer(2:n)

      _RETURN(_SUCCESS)
   end subroutine deserialize_int32_1d

   subroutine deserialize_int64_0d(buffer, scalar, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      integer(kind=INT64), intent(out) :: scalar
      integer, optional, intent(out) :: rc

      _ASSERT(size(buffer) >= 1, "wrong buffer")      

      scalar = transfer(buffer(1:), scalar)

      _RETURN(_SUCCESS)
   end subroutine deserialize_int64_0d


   subroutine deserialize_int64_1d(buffer, array, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      integer(kind=INT64), allocatable, intent(out) :: array(:)
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: n

      _ASSERT(size(buffer) >= 1, "wrong buffer")      

      n = buffer(1)
      allocate(array(n-1))
      array = transfer(buffer(2:n),array)

      _RETURN(_SUCCESS)
   end subroutine deserialize_int64_1d

   subroutine deserialize_real32_0d(buffer, scalar, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      real(kind=REAL32), intent(out) :: scalar
      integer, optional, intent(out) :: rc

      _ASSERT(size(buffer) >= 1, "wrong buffer")      
      scalar = transfer(buffer(1),scalar)
      _RETURN(_SUCCESS)
   end subroutine deserialize_real32_0d


   subroutine deserialize_real32_1d(buffer, array, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      real(kind=REAL32), allocatable, intent(out) :: array(:)
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: n

      _ASSERT(size(buffer) >= 1, "wrong buffer")      

      n = buffer(1)
      allocate(array(n-1))
      array = transfer(buffer(2:n),array)

      _RETURN(_SUCCESS)
   end subroutine deserialize_real32_1d

   subroutine deserialize_real64_0d(buffer, scalar, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      real(kind=REAL64), intent(out) :: scalar
      integer, optional, intent(out) :: rc

      _ASSERT(size(buffer) >= 1, "wrong buffer")      
      scalar = transfer(buffer(1:),scalar)
      _RETURN(_SUCCESS)
   end subroutine deserialize_real64_0d


   subroutine deserialize_real64_1d(buffer, array, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      real(kind=REAL64), allocatable, intent(out) :: array(:)
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: n


      _ASSERT(size(buffer) >= 1, "wrong buffer")      
      n = buffer(1)
      allocate(array(n-1))
      array = transfer(buffer(2:n),array)

      _RETURN(_SUCCESS)
   end subroutine deserialize_real64_1d

   subroutine deserialize_logical_0d(buffer, scalar, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      logical, intent(out) :: scalar
      integer, optional, intent(out) :: rc

      _ASSERT(size(buffer) >= 1, "wrong buffer")      
      scalar = buffer(1) /= 0

      _RETURN(_SUCCESS)
   end subroutine deserialize_logical_0d


   subroutine deserialize_logical_1d(buffer, array, rc)
      integer(kind=INT32), intent(in) :: buffer(:)
      logical, allocatable, intent(out) :: array(:)
      integer, optional, intent(out) :: rc

      integer(kind=INT32) :: n

      _ASSERT(size(buffer) >= 1, "wrong buffer")      
      n = buffer(1)
      allocate(array(n-1))
     
      array = buffer(2:n) /= 0

      _RETURN(_SUCCESS)
   end subroutine deserialize_logical_1d

   elemental function nearlyEqual_real32(r1, r2) result(yes)
      real(kind=REAL32), intent(in) :: r1
      real(kind=REAL32), intent(in) :: r2
      logical :: yes
      real(kind=REAL32) :: eps
      ! WY note: relax the nearly equal by 5.0* epsilon  ?
      eps = epsilon(r1) ! *5.0
      yes = (abs(r1-r2) <=  maxval([abs(r1),abs(r2)])*eps)
   end function

   elemental function nearlyEqual_real64(r1, r2) result(yes)
      real(kind=REAL64), intent(in) :: r1
      real(kind=REAL64), intent(in) :: r2
      logical :: yes
      real(kind=REAL64) :: eps
      ! WY note: relax the nearly equal by 5.0* epsilon ?
      eps = epsilon(r1) ! *5.0
      yes = (abs(r1-r2) <=  maxval([abs(r1),abs(r2)])*eps)
   end function

   ! In multiples of default integer ...
   integer function word_size(type_kind,rc)
      integer, intent(in) :: type_kind
      integer, optional, intent(out) :: rc
      integer(kind=INT32) :: i32
      integer(kind=INT64) :: i64
      real (kind=REAL32) :: r32
      real (kind=REAL64) :: r64

      select case(type_kind)
      case (pFIO_INT32)
         word_size = 1
      case (pFIO_REAL32)
         word_size = c_sizeof(r32)/c_sizeof(i32)
      case (pFIO_LOGICAL)
         word_size = 1
      case (pFIO_REAL64)
         word_size = c_sizeof(r64)/c_sizeof(i32)
      case (pFIO_INT64)
         word_size = c_sizeof(i64)/c_sizeof(i32)
      case default
         _FAIL( "unsupported type kind")
      end select
         
      _RETURN(_SUCCESS)
   end function word_size

   function i_to_string(count, rc) result(str)
      character(len=:), allocatable :: str
      integer, intent(in) :: count
      integer, optional, intent(out) :: rc
      character(len=9)    :: buffer
      _ASSERT( count <= 10**8, "too big to hold")
      write(buffer,'(i0)') count
      str = trim(buffer)

      _RETURN(_SUCCESS)
   end function i_to_string

end module pFIO_UtilitiesMod