Test_FieldBLAS.pf

This file depends on

Help
Source Code

#include "MAPL_Generic.h"

module Test_FieldBLAS

   use mapl_FieldBLAS
   use field_utils_setup
   use MAPL_FieldPointerUtilities
   use ESMF
   use pfunit
   use MAPL_ExceptionHandling
   use, intrinsic :: iso_c_binding, only: c_ptr

   implicit none

contains

   @Before
   subroutine set_up_data(this)
      class(MpiTestMethod), intent(inout) :: this

      integer :: status, rc

      real(kind=ESMF_KIND_R4), parameter :: ADD_R4 = 100.0
      real(kind=ESMF_KIND_R8), parameter :: ADD_R8 = 100.0
      real(kind=ESMF_KIND_R4), allocatable :: y4array(:,:)
      real(kind=ESMF_KIND_R8), allocatable :: y8array(:,:)

      allocate(y4array, source=R4_ARRAY_DEFAULT)
      allocate(y8array, source=R8_ARRAY_DEFAULT)
      y4array = y4array + ADD_R4
      y8array = y8array + ADD_R8
      XR4 = mk_field(R4_ARRAY_DEFAULT, name = 'XR4', _RC)
      YR4 = mk_field(y4array, name = 'YR4', _RC)
      XR8 = mk_field(R8_ARRAY_DEFAULT, name = 'XR8', _RC)
      YR8 = mk_field(y8array, name = 'YR8', _RC)
      XR4_3D = mk_field_r4_ungrid(name = 'XR4_3D', ungriddedLBound=[1],ungriddedUBound=[3],_RC)
      YR4_3D = mk_field_r4_ungrid(name = 'YR4_3D',ungriddedLBound=[1],ungriddedUBound=[3], _RC)

   end subroutine set_up_data

   @after
   subroutine teardown(this)
      class(MpiTestMethod), intent(inout) :: this
   end subroutine teardown

   @Test(npes=[4])
   ! Basic test of FieldCOPY subroutine (REAL32)
   subroutine test_FieldCOPY_R4(this)
      class(MpiTestMethod), intent(inout) :: this
      type(ESMF_Field) :: x
      type(ESMF_Field) :: y
      real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: x_ptr
      real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: y_ptr
      integer :: status, rc

      x = XR4
      y = YR4
      call FieldCOPY(x, y, _RC)
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC)
      @assertEqual(x_ptr, y_ptr)

   end subroutine test_FieldCOPY_R4

   @Test(npes=[4])
   ! Basic test of FieldCOPY subroutine (REAL64)
   subroutine test_FieldCOPY_R8(this)
      class(MpiTestMethod), intent(inout) :: this
      type(ESMF_Field) :: x
      type(ESMF_Field) :: y
      real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr
      real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: y_ptr
      integer :: status, rc

      x = XR8
      y = YR8
      call FieldCOPY(x, y, _RC)
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC)
      @assertEqual(x_ptr, y_ptr)

   end subroutine test_FieldCOPY_R8

   @Test(npes=[4])
   ! Basic test of FieldCOPY subroutine (REAL32 -> REAL64)
   subroutine test_FieldCOPY_R4R8(this)
      class(MpiTestMethod), intent(inout) :: this
      type(ESMF_Field) :: x
      type(ESMF_Field) :: y
      real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: x_ptr
      real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: y_ptr
      integer :: status, rc

      x = XR4
      y = YR8
      call FieldCOPY(x, y, _RC)
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC)
      @assertEqual(x_ptr, y_ptr)

   end subroutine test_FieldCOPY_R4R8

   @Test(npes=[4])
   ! Basic test of FieldCOPY subroutine (REAL64 -> REAL32)
   subroutine test_FieldCOPY_R8R4(this)
      class(MpiTestMethod), intent(inout) :: this
      type(ESMF_Field) :: x
      type(ESMF_Field) :: y
      real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr
      real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: y_ptr
      integer :: status, rc

      x = XR8
      y = YR4
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      x_ptr = 4.d0
      call FieldCOPY(x, y, _RC)
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC)
      @assertTrue(all(are_almost_equal(x_ptr, y_ptr)), 'Values differ above threshold.')

   end subroutine test_FieldCOPY_R8R4

   @Test(npes=[4])
   ! Basic test of FieldSCAL subroutine (REAL32)
   subroutine test_FieldSCAL_R4(this)
      class(MpiTestMethod), intent(inout) :: this
      real(kind=ESMF_KIND_R4), parameter :: a = 2.0
      type(ESMF_Field) :: x
      real(kind=ESMF_KIND_R4), dimension(:,:), allocatable :: x_array
      real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: x_ptr
      integer :: status, rc

      x = XR4
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      x_array = x_ptr
      call FieldSCAL(a, x, _RC)
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      @assertEqual(x_ptr, a*x_array)

   end subroutine test_FieldSCAL_R4

   @Test(npes=[4])
   ! Basic test of FieldSCAL subroutine (REAL64)
   subroutine test_FieldSCAL_R8(this)
       class(MpiTestMethod), intent(inout) :: this
     real(kind=ESMF_KIND_R8), parameter :: a = 2.0
      type(ESMF_Field) :: x
      real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: x_array
      real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr
      integer :: status, rc

      x = XR8
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      x_array = x_ptr
      call FieldSCAL(a, x, _RC)
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      @assertEqual(x_ptr, a*x_array)

   end subroutine test_FieldSCAL_R8

   @Test(npes=[4])
   !
   subroutine test_FieldAXPY_R4(this)
      class(MpiTestMethod), intent(inout) :: this
      real(kind=ESMF_KIND_R4), parameter :: a = 2.0
      type(ESMF_Field) :: x
      type(ESMF_Field) :: y
      real(kind=ESMF_KIND_R4), dimension(:,:), allocatable :: x_array
      real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: x_ptr
      real(kind=ESMF_KIND_R4), dimension(:,:), allocatable :: y_array
      real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: y_ptr
      integer :: status, rc

      x = XR4
      y = YR4
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      x_array = x_ptr
      call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC)
      y_array = y_ptr
      call FieldAXPY(a, x, y, _RC)
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC)
      @assertEqual(y_ptr, a*x_array+y_array)

   end subroutine test_FieldAXPY_R4

   @Test(npes=[4])
   !
   subroutine test_FieldAXPY_R8(this)
       class(MpiTestMethod), intent(inout) :: this
     real(kind=ESMF_KIND_R8), parameter :: a = 2.0
      type(ESMF_Field) :: x
      type(ESMF_Field) :: y
      real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: x_array
      real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr
      real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: y_array
      real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: y_ptr
      integer :: status, rc

      x = XR8
      y = YR8
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      x_array = x_ptr
      call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC)
      y_array = y_ptr
      call FieldAXPY(a, x, y, _RC)
      call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC)
      call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC)

   end subroutine test_FieldAXPY_R8

   @Test(npes=[4])
   subroutine test_FieldGetLocalElementCount(this)
      class(MpiTestMethod), intent(inout) :: this
      type(ESMF_Field) :: x
      integer :: rank
      integer, allocatable :: expected_count(:)
      integer, allocatable :: actual_count(:)
      integer :: status, rc

      x = XR4
      call ESMF_FieldGet(x, rank=rank, _RC)
      allocate(expected_count(rank))
      call ESMF_FieldGet(x, localElementCount=expected_count, _RC)
      actual_count = FieldGetLocalElementCount(x, _RC)
      @assertEqual(actual_count, expected_count)

   end subroutine test_FieldGetLocalElementCount

   @Test(npes=[4])
    !
   subroutine test_FieldGetLocalSize(this)
      class(MpiTestMethod), intent(inout) :: this
      type(ESMF_Field) :: x
      integer :: status, rc
      integer :: rank
      integer :: expected_size
      integer :: actual_size
      integer, allocatable :: element_count(:)

      x = XR4
      call ESMF_FieldGet(x, rank=rank, _RC)
      allocate(element_count(rank))
      call ESMF_FieldGet(x, localElementCount=element_count, _RC)
      expected_size = sum(element_count)
      actual_size=FieldGetLocalSize(x, _RC)
      @assertEqual(actual_size, expected_size)
      if(allocated(element_count)) deallocate(element_count)

   end subroutine test_FieldGetLocalSize

   @Test(npes=[4])
   ! Test getting the c_ptr for a field
   !wdb fixme  Should test more extensively for different ranks
   !wdb fixme  Should test for ESMF_KIND_I4 and ESMF_KIND_I8
   !wdb fixme  Should check c_cptr from tested method against independent test
   subroutine test_FieldGetCptr(this)
       class(MpiTestMethod), intent(inout) :: this
     type(ESMF_Field) :: x
      type(c_ptr) :: cptr
      integer :: status, rc

      x = XR4
      call FieldGetCptr(x, cptr, _RC)
      x = XR8
      call FieldGetCptr(x, cptr, _RC)

   end subroutine test_FieldGetCptr

   @Test(npes=[4])
   !wdb fixme  Probably should test for non-conformable fields
   subroutine test_FieldsAreConformableR4(this)
      class(MpiTestMethod), intent(inout) :: this
      type(ESMF_Field) :: x, y
      integer :: status, rc
      logical :: are_conformable

      x = XR4
      y = YR4
      are_conformable = .FALSE.
      are_conformable = FieldsAreConformable(x, y, _RC)
      @assertTrue(are_conformable)

   end subroutine test_FieldsAreConformableR4

   !wdb fixme  Probably should test for non-conformable fields
   @Test(npes=[4])
   subroutine test_FieldsAreConformableR8(this)
       class(MpiTestMethod), intent(inout) :: this
     type(ESMF_Field) :: x, y
      integer :: status, rc
      logical :: are_conformable

      x = XR8
      y = YR8
      are_conformable = .FALSE.
      are_conformable = FieldsAreConformable(x, y, _RC)
      @assertTrue(are_conformable)

   end subroutine test_FieldsAreConformableR8

   @Test(npes=[4])
   !
   subroutine test_FieldsAreSameTypeKind(this)
      class(MpiTestMethod), intent(inout) :: this
      type(ESMF_Field) :: x, y
      integer :: status, rc
      logical :: are_same_typekind

      x = XR4
      y = YR4
      are_same_typekind = .FALSE.
      are_same_typekind = FieldsAreSameTypeKind(x, y, _RC)
      @assertTrue(are_same_typekind)
      x = XR8
      y = YR8
      are_same_typekind = .FALSE.
      are_same_typekind = FieldsAreSameTypeKind(x, y, _RC)
      @assertTrue(are_same_typekind)
      y = YR4
      are_same_typekind = .TRUE.
      are_same_typekind = FieldsAreSameTypeKind(x, y, _RC)
      @assertFalse(are_same_typekind)
      are_same_typekind = .TRUE.
      are_same_typekind = FieldsAreSameTypeKind(y, x, _RC)
      @assertFalse(are_same_typekind)

   end subroutine test_FieldsAreSameTypeKind

   @Test(npes=[4])
   subroutine test_FieldConvertPrec_R4R8(this)
       class(MpiTestMethod), intent(inout) :: this
     integer, parameter :: NROWS = 2
      integer, parameter :: NCOLS = NROWS
      type(ESMF_Field) :: r4_field, r8_field
      real(kind=ESMF_KIND_R4) :: r4_data(NROWS,NCOLS)
      real(kind=ESMF_KIND_R8) :: r8_data(NROWS,NCOLS)
      real(kind=ESMF_KIND_R8) :: r8_converted(NROWS,NCOLS)
      real(kind=ESMF_KIND_R8), pointer :: r8_pointer(:,:)
      integer :: rc, status

      call initialize_array(r4_data, 0.0, 1.0)
      r8_data = 0.0
      r8_converted = r4_data
      r4_field = mk_field(r4_data, name = 'XR4', _RC)
      r8_field = mk_field(r8_data, name = 'YR8', _RC)
      call FieldConvertPrec(r4_field, r8_field, _RC)
      call ESMF_FieldGet(r8_field, farrayPtr = r8_pointer, _RC)
      @assertEqual(r8_converted, r8_pointer)

   end subroutine test_FieldConvertPrec_R4R8

   @Test(npes=[4])
   subroutine test_FieldClone3D(this)
      class(MpiTestMethod), intent(inout) :: this
      type(ESMF_Field) :: x, y
      integer :: status, rc

      type(ESMF_TypeKind_Flag) :: tk_x,tk_y
      type(ESMF_Grid) :: grid
      integer, allocatable :: ungriddedLBound_x(:),ungriddedLBound_y(:)
      integer, allocatable :: ungriddedUBound_x(:),ungriddedUBound_y(:)
      integer :: grid_rank_x, grid_rank_y
      integer :: field_rank_x, field_rank_y
      integer :: ungrid_x,ungrid_y

      x = XR4_3D

      call ESMF_FieldGet(x,rank=field_rank_x,grid=grid,typekind=tk_x,_RC)
      call ESMF_GridGet(grid,dimCount=grid_rank_x)
      ungrid_x = field_rank_x - grid_rank_x
      allocate(ungriddedLBound_x(ungrid_x),ungriddedUBound_x(ungrid_x))
      call ESMF_FieldGet(x,ungriddedLBound=UngriddedLBound_x,ungriddedUBound=UngriddedUBound_x,_RC)

      call FieldClone(x, y, _RC)

      call ESMF_FieldGet(y,rank=field_rank_y,grid=grid,typekind=tk_y,_RC)
      call ESMF_GridGet(grid,dimCount=grid_rank_y)
      ungrid_y = field_rank_y - grid_rank_y
      allocate(ungriddedLBound_y(ungrid_y),ungriddedUBound_y(ungrid_y))
      call ESMF_FieldGet(y,ungriddedLBound=UngriddedLBound_y,ungriddedUBound=UngriddedUBound_y,_RC)
      @assertEqual(field_rank_x,field_rank_y)
      @assertEqual(ungrid_x,ungrid_y)
      @assertTrue(tk_x==tk_y,"kinds not equal")
      @assertEqual(ungriddedLBound_x,ungriddedLBound_y)
      @assertEqual(ungriddedUBound_x,ungriddedUBound_y)

   end subroutine test_FieldClone3D

   @Test(npes=[4])
   subroutine test_almost_equal_scalar(this)
      class(MpiTestMethod), intent(inout) :: this
      character(len=*), parameter :: MSG = 'Difference exceeds threshold'
      real(kind=ESMF_KIND_R8), parameter :: X = 1.0 / 3.0
      real(kind=ESMF_KIND_R4) :: y

      y = X
      @assertTrue(are_almost_equal(X, y), trim(MSG))

   end subroutine test_almost_equal_scalar

   @Test(npes=[4])
   subroutine test_almost_equal_array(this)
      class(MpiTestMethod), intent(inout) :: this
      integer, parameter :: N = 3
      character(len=*), parameter :: MSG = 'Difference exceeds threshold'
      real(kind=ESMF_KIND_R8), parameter :: DENOMS(N) = [3.0, 5.0, 7.0]
      real(kind=ESMF_KIND_R8), parameter :: X(N) = 1.0 / DENOMS
      real(kind=ESMF_KIND_R4) :: y(N)

      y = X

      @assertTrue(all(are_almost_equal(x, y)), trim(MSG))

   end subroutine test_almost_equal_array

end module Test_FieldBLAS
Test_FieldBLAS.pf Source File

Contents

Modules

Source Code

This file depends on

Source Code
