ArrayReference.F90 Source File

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

module pFIO_ArrayReferenceMod
   use, intrinsic :: iso_c_binding, only: C_NULL_PTR
   use, intrinsic :: iso_c_binding, only: c_loc, c_ptr
   use, intrinsic :: iso_fortran_env, only: INT32
   use, intrinsic :: iso_fortran_env, only: INT64
   use, intrinsic :: iso_fortran_env, only: REAL32
   use, intrinsic :: iso_fortran_env, only: REAL64
   use MAPL_ExceptionHandling
   use pFIO_ConstantsMod
   use pFIO_AbstractDataReferenceMod

   implicit none
   private

   public :: ArrayReference

   type,extends(AbstractDataReference) :: ArrayReference
   contains
      procedure :: get_length
      procedure :: serialize
      procedure :: deserialize
   end type ArrayReference

   interface ArrayReference
      procedure new_ArrayReference_from_param
      procedure new_ArrayReference_0d
      procedure new_ArrayReference_1d
      procedure new_ArrayReference_2d
      procedure new_ArrayReference_3d
      procedure new_ArrayReference_4d
      procedure new_ArrayReference_5d
   end interface ArrayReference

contains

   function new_ArrayReference_from_param(in_c_loc, in_kind, in_shape) result(reference)
      type (ArrayReference) :: reference
      type(c_ptr), intent(in) :: in_c_loc
      integer, intent(in) :: in_kind
      integer, intent(in) :: in_shape(:)
      reference%base_address = in_c_loc
      reference%shape = in_shape
      reference%type_kind = in_kind
   end function

   function new_ArrayReference_0d(scalar, rc) result(reference)
      type (ArrayReference) :: reference
      class(*), target, intent(in) :: scalar
      integer, optional, intent(out) :: rc

      select type (scalar)
      type is (real(kind=REAL32))
         reference%base_address = c_loc(scalar)
      type is (real(kind=REAL64))
         reference%base_address = c_loc(scalar)
      type is (integer(kind=INT32))
         reference%base_address = c_loc(scalar)
      type is (integer(kind=INT64))
         reference%base_address = c_loc(scalar)
      class default
         _FAIL( "ArrayRef does not support this type")
      end select
      reference%shape = shape(scalar)
      reference%type_kind = type_kind(scalar)
      _RETURN(_SUCCESS)
   end function new_ArrayReference_0d

   function new_ArrayReference_1d(array, rc) result(reference)
      type (ArrayReference) :: reference
      class(*), target, intent(in) :: array(:)
      integer, optional, intent(out) :: rc

      logical :: has_address

      has_address = (size(array) /= 0)
      reference%base_address=C_NULL_PTR

      select type (array)
      type is (real(kind=REAL32))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_REAL32
      type is (real(kind=REAL64))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_REAL64
      type is (integer(kind=INT32))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_INT32
      type is (integer(kind=INT64))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_INT64
      class default
         _FAIL( "ArrayRef does not support this type")
      end select
      reference%shape = shape(array)

      _RETURN(_SUCCESS)
      
   end function new_ArrayReference_1d

   function new_ArrayReference_2d(array, rc) result(reference)
      type (ArrayReference) :: reference
      class(*), target, intent(in) :: array(:,:)
      integer, optional, intent(out) :: rc

      logical :: has_address

      has_address = (size(array) /= 0)
      reference%base_address=C_NULL_PTR

      select type (array)
      type is (real(kind=REAL32))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_REAL32
      type is (real(kind=REAL64))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_REAL64
      type is (integer(kind=INT32))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_INT32
      type is (integer(kind=INT64))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_INT64
      class default
         _FAIL( "ArrayRef does not support this type")
      end select
      reference%shape = shape(array)

      _RETURN(_SUCCESS)

   end function new_ArrayReference_2d

   function new_ArrayReference_3d(array, rc) result(reference)
      type (ArrayReference) :: reference
      class(*), target, intent(in) :: array(:,:,:)
      integer, optional, intent(out) :: rc

      logical :: has_address

      has_address = (size(array) /= 0)
      reference%base_address=C_NULL_PTR

      select type (array)
      type is (real(kind=REAL32))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_REAL32
      type is (real(kind=REAL64))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_REAL64
      type is (integer(kind=INT32))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_INT32
      type is (integer(kind=INT64))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_INT64
      class default
         _FAIL( "ArrayRef does not support this type")
      end select
      reference%shape = shape(array)

      _RETURN(_SUCCESS)
      
   end function new_ArrayReference_3d


   function new_ArrayReference_4d(array, rc) result(reference)
      type (ArrayReference) :: reference
      class(*), target, intent(in) :: array(:,:,:,:)
      integer, optional, intent(out) :: rc

      logical :: has_address

      has_address = (size(array) /= 0)
      reference%base_address=C_NULL_PTR

      select type (array)
      type is (real(kind=REAL32))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_REAL32
      type is (real(kind=REAL64))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_REAL64
      type is (integer(kind=INT32))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_INT32
      type is (integer(kind=INT64))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_INT64
      class default
         _FAIL( "ArrayRef does not support this type")
      end select
      reference%shape = shape(array)

      _RETURN(_SUCCESS)
      
   end function new_ArrayReference_4d

   function new_ArrayReference_5d(array, rc) result(reference)
      type (ArrayReference) :: reference
      class(*), target, intent(in) :: array(:,:,:,:,:)
      integer, optional, intent(out) :: rc

      logical :: has_address

      has_address = (size(array) /= 0)
      reference%base_address=C_NULL_PTR

      select type (array)
      type is (real(kind=REAL32))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_REAL32
      type is (real(kind=REAL64))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_REAL64
      type is (integer(kind=INT32))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_INT32
      type is (integer(kind=INT64))
         if (has_address)   reference%base_address = c_loc(array)
         reference%type_kind = pFIO_INT64
      class default
         _FAIL( "ArrayRef does not support this type")
      end select

      reference%shape = shape(array)

      _RETURN(_SUCCESS)
      
   end function new_ArrayReference_5d

   integer function type_kind(element, rc)
      class(*), intent(in) :: element
      integer, optional, intent(out) :: rc

      select type (element)
      type is (integer(kind=INT32))
         type_kind = pFIO_INT32
      type is (integer(kind=INT64))
         type_kind = pFIO_INT64
      type is (real(kind=REAL32))
         type_kind = pFIO_REAL32
      type is (real(kind=REAL64))
         type_kind = pFIO_REAL64
      class default
         _FAIL('kind error')
      end select
      _RETURN(_SUCCESS)
   end function type_kind

   integer function get_length(this) result(length)
      class (ArrayReference), intent(in) :: this

      length = this%get_length_base()

   end function get_length

   subroutine serialize(this, buffer, rc)
      class (ArrayReference), intent(in) :: this
      integer, allocatable :: buffer(:)
      integer, optional, intent(out) :: rc
      integer :: status

      call this%serialize_base(buffer, rc=status)
      _VERIFY(status)
      _RETURN(_SUCCESS)
   end subroutine serialize

   subroutine deserialize(this, buffer, rc)
      class (ArrayReference), intent(inout) :: this
      integer, intent(in) :: buffer(:)
      integer, optional, intent(out) :: rc
      integer :: status

      call this%deserialize_base(buffer, rc=status)
      _VERIFY(status)
      _RETURN(_SUCCESS)
   end subroutine deserialize

end module pFIO_ArrayReferenceMod