program ESMF_FieldBundleSMMUTest
!------------------------------------------------------------------------------
! INCLUDES
#include "ESMF.h"
#include "ESMF_Macros.inc"
!
!==============================================================================
!BOPI
! !PROGRAM: ESMF_FieldBundleSMMUTest - This test verifies FieldBundleSMM functionality.
!
! !DESCRIPTION:
!
! The code in this file specializes on testing the usage of FiledSMM.
!EOPI
!
!-----------------------------------------------------------------------------
! !USES:
use ESMF_TestMod ! test methods
use ESMF
implicit none
!------------------------------------------------------------------------------
! The following line turns the CVS identifier string into a printable variable.
character(*), parameter :: version = &
'$Id$'
!------------------------------------------------------------------------------
! cumulative result: count failures; no failures equals "all pass"
integer :: result = 0
! individual test result code
integer :: rc = ESMF_SUCCESS
! test error messages
character(ESMF_MAXSTR) :: failMsg, name
! used for field bundle SMM store tests
integer :: srcTermProcessingSingle(1), srcTermProcessingDouble(2), ii
call ESMF_TestStart(ESMF_SRCLINE, rc=rc)
if(rc /= ESMF_SUCCESS) &
call ESMF_Finalize(endflag=ESMF_END_ABORT)
#ifdef ESMF_TESTEXHAUSTIVE
! ------------------------------------------------------------------------------
!EX_UTest_Multi_Proc_Only
write(name, *) "ESMF_FieldBundleSMMStoreFromFile Test"
write(failMsg, *) "Did not return ESMF_SUCCESS"
call test_field_bundle_smm_store_from_file(rc)
#ifdef ESMF_NETCDF
call ESMF_Test((rc .eq. ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
#else
write(failMsg, *) "Did not return ESMF_RC_LIB_NOT_PRESENT"
call ESMF_Test((rc==ESMF_RC_LIB_NOT_PRESENT), name, failMsg, result, ESMF_SRCLINE)
#endif
! ------------------------------------------------------------------------------
!EX_UTest_Multi_Proc_Only
write(name, *) "ESMF_FieldBundleSMMStoreFromFile Test (srcTermProcessing=(/-1/))"
write(failMsg, *) "Did not return ESMF_SUCCESS"
srcTermProcessingSingle = (/-1/)
call test_field_bundle_smm_store_from_file(rc, &
srcTermProcessing=srcTermProcessingSingle)
! The source term processing value should be adjusted by the store call
! during optimizations.
if (rc == ESMF_SUCCESS .and. srcTermProcessingSingle(1) .lt. 0) then
rc = ESMF_FAILURE
endif
#ifdef ESMF_NETCDF
call ESMF_Test((rc .eq. ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
#else
write(failMsg, *) "Did not return ESMF_RC_LIB_NOT_PRESENT"
call ESMF_Test((rc==ESMF_RC_LIB_NOT_PRESENT), name, failMsg, result, ESMF_SRCLINE)
#endif
! ------------------------------------------------------------------------------
!EX_UTest_Multi_Proc_Only
write(name, *) "ESMF_FieldBundleSMMStore Source Term Processing Test - (/-1, -1/)"
write(failMsg, *) "Did not return ESMF_SUCCESS"
srcTermProcessingDouble = (/-1, -1/)
call test_field_bundle_smm_source_term_processing(srcTermProcessingDouble, rc)
if (rc == ESMF_SUCCESS) then
do ii=1,2
if (srcTermProcessingDouble(ii) .lt. 0) then
rc = ESMF_FAILURE
exit
endif
enddo
endif
call ESMF_Test((rc .eq. ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
! ------------------------------------------------------------------------------
!EX_UTest_Multi_Proc_Only
write(name, *) "ESMF_FieldBundleSMMStore Source Term Processing Test - (/1, 1/)"
write(failMsg, *) "Did not return ESMF_SUCCESS"
srcTermProcessingDouble = (/1, 1/)
call test_field_bundle_smm_source_term_processing(srcTermProcessingDouble, rc)
call ESMF_Test((rc .eq. ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
! ------------------------------------------------------------------------------
!EX_UTest_Multi_Proc_Only
write(name, *) "ESMF_FieldBundleSMMStore Source Term Processing Test - (/1/)"
write(failMsg, *) "Did not return ESMF_SUCCESS"
srcTermProcessingSingle = (/1/)
call test_field_bundle_smm_source_term_processing(srcTermProcessingSingle, rc)
if (srcTermProcessingSingle(1) .ne. 1) then
rc = ESMF_FAILURE
endif
call ESMF_Test((rc .eq. ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
! --------------------------------------------------------------------------
if (.not. ESMF_TestMinPETs(4, ESMF_SRCLINE)) &
call ESMF_Finalize(endflag=ESMF_END_ABORT)
!------------------------------------------------------------------------
!EX_UTest_Multi_Proc_Only
call test_smm_1db(rc)
write(failMsg, *) ""
write(name, *) "FieldBundleSMM test using lpe for both src and dst, with halos"
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest_Multi_Proc_Only
call test_smm_1dbweak(rc)
write(failMsg, *) ""
write(name, *) "FieldBundleSMM test using lpe for both src and dst, with halos compatible"
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
#endif
call ESMF_TestEnd(ESMF_SRCLINE)
#ifdef ESMF_TESTEXHAUSTIVE
contains
#undef ESMF_METHOD
#define ESMF_METHOD "test_smm_1db"
subroutine test_smm_1db(rc)
integer, intent(out) :: rc
! local arguments used to create field etc
type(ESMF_FieldBundle) :: srcFieldBundle, dstFieldBundle
type(ESMF_Field) :: srcField(3), dstField(3)
type(ESMF_Grid) :: grid
type(ESMF_DistGrid) :: distgrid
type(ESMF_VM) :: vm
type(ESMF_RouteHandle) :: routehandle
type(ESMF_ArraySpec) :: arrayspec
integer :: localrc, lpe, i, l
integer, pointer :: srcfptr(:), dstfptr(:)
integer, pointer :: fptr(:)
integer :: exlb(1), exub(1)
integer(ESMF_KIND_I4), allocatable :: factorList(:)
integer, allocatable :: factorIndexList(:,:)
rc = ESMF_SUCCESS
localrc = ESMF_SUCCESS
call ESMF_VMGetCurrent(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, localPet=lpe, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! create distgrid and grid
distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/16/), &
regDecomp=(/4/), &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
grid = ESMF_GridCreate(distgrid=distgrid, &
gridEdgeLWidth=(/0/), gridEdgeUWidth=(/0/), &
name="grid", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_I4, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! create field bundles and fields
srcFieldBundle = ESMF_FieldBundleCreate(rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstFieldBundle = ESMF_FieldBundleCreate(rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
do i = 1, 3
srcField(i) = ESMF_FieldCreate(grid, arrayspec, &
totalLWidth=(/1/), totalUWidth=(/2/), &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldGet(srcField(i), localDe=0, farrayPtr=srcfptr, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
srcfptr = 1
call ESMF_FieldBundleAdd(srcFieldBundle, (/srcField(i)/), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstField(i) = ESMF_FieldCreate(grid, arrayspec, &
totalLWidth=(/1/), totalUWidth=(/2/), &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldGet(dstField(i), localDe=0, farrayPtr=dstfptr, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstfptr = 0
call ESMF_FieldBundleAdd(dstFieldBundle, (/dstField(i)/), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
enddo
! initialize factorList and factorIndexList
allocate(factorList(4))
allocate(factorIndexList(2,4))
factorList = (/1,2,3,4/)
factorIndexList(1,:) = (/lpe*4+1,lpe*4+2,lpe*4+3,lpe*4+4/)
factorIndexList(2,:) = (/lpe*4+1,lpe*4+2,lpe*4+3,lpe*4+4/)
call ESMF_FieldBundleSMMStore(srcFieldBundle, dstFieldBundle, &
routehandle, factorList, factorIndexList, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! perform smm
call ESMF_FieldBundleSMM(srcFieldBundle, dstFieldBundle, routehandle, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! verify smm
do l = 1, 3
call ESMF_FieldGet(dstField(l), localDe=0, farrayPtr=fptr, &
exclusiveLBound=exlb, exclusiveUBound=exub, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Verify that the smm data in dstField(l) is correct.
! Before the smm op, the dst Field contains all 0.
! The smm op reset the values to the index value, verify this is the case.
!write(*, '(9I3)') l, lpe, fptr
do i = exlb(1), exub(1)
if(fptr(i) .ne. i) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
enddo
! release SMM route handle
call ESMF_FieldBundleSMMRelease(routehandle, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! release all acquired resources
call ESMF_FieldBundleDestroy(srcFieldBundle)
call ESMF_FieldBundleDestroy(dstFieldBundle)
do l = 1, 3
call ESMF_FieldDestroy(srcField(l))
call ESMF_FieldDestroy(dstField(l))
enddo
call ESMF_GridDestroy(grid)
call ESMF_DistGridDestroy(distgrid)
deallocate(factorList, factorIndexList)
rc = ESMF_SUCCESS
end subroutine test_smm_1db
!------------------------------------------------------------------------
#undef ESMF_METHOD
#define ESMF_METHOD "test_smm_1dbweak"
subroutine test_smm_1dbweak(rc)
integer, intent(out) :: rc
! local arguments used to create field etc
type(ESMF_FieldBundle) :: srcFieldBundle, dstFieldBundle
type(ESMF_FieldBundle) :: srcFieldBundleA, dstFieldBundleA
type(ESMF_Field) :: srcField(3), dstField(3)
type(ESMF_Field) :: srcFieldA(3), dstFieldA(3)
type(ESMF_Grid) :: grid
type(ESMF_DistGrid) :: distgrid
type(ESMF_VM) :: vm
type(ESMF_RouteHandle) :: routehandle
type(ESMF_ArraySpec) :: arrayspec
integer :: localrc, lpe, i, j, l
integer, pointer :: srcfptr(:,:), dstfptr(:,:)
integer, pointer :: fptr(:,:)
integer :: exlb(2), exub(2)
integer(ESMF_KIND_I4), allocatable :: factorList(:)
integer, allocatable :: factorIndexList(:,:)
rc = ESMF_SUCCESS
localrc = ESMF_SUCCESS
call ESMF_VMGetCurrent(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, localPet=lpe, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! create distgrid and grid
distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/16/), &
regDecomp=(/4/), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
grid = ESMF_GridCreate(distgrid=distgrid, &
gridEdgeLWidth=(/0/), gridEdgeUWidth=(/0/), &
name="grid", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_ArraySpecSet(arrayspec, 2, ESMF_TYPEKIND_I4, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! create field bundles and fields
srcFieldBundle = ESMF_FieldBundleCreate(rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstFieldBundle = ESMF_FieldBundleCreate(rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
srcFieldBundleA = ESMF_FieldBundleCreate(rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstFieldBundleA = ESMF_FieldBundleCreate(rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
do i = 1, 3
srcField(i) = ESMF_FieldCreate(grid, arrayspec, &
ungriddedLBound=(/1/), ungriddedUBound=(/8/), &
totalLWidth=(/1/), totalUWidth=(/2/), &
gridToFieldMap=(/2/), &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
srcFieldA(i) = ESMF_FieldCreate(grid, arrayspec, &
ungriddedLBound=(/1/), ungriddedUBound=(/5/), &
totalLWidth=(/1/), totalUWidth=(/2/), &
gridToFieldMap=(/2/), &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldGet(srcFieldA(i), localDe=0, farrayPtr=srcfptr, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
srcfptr = 1
call ESMF_FieldBundleAdd(srcFieldBundle, (/srcField(i)/), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldBundleAdd(srcFieldBundleA, (/srcFieldA(i)/), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstField(i) = ESMF_FieldCreate(grid, arrayspec, &
ungriddedLBound=(/1/), ungriddedUBound=(/8/), &
totalLWidth=(/1/), totalUWidth=(/2/), &
gridToFieldMap=(/2/), &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstFieldA(i) = ESMF_FieldCreate(grid, arrayspec, &
ungriddedLBound=(/1/), ungriddedUBound=(/5/), &
totalLWidth=(/1/), totalUWidth=(/2/), &
gridToFieldMap=(/2/), &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldGet(dstFieldA(i), localDe=0, farrayPtr=dstfptr, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstfptr = 0
call ESMF_FieldBundleAdd(dstFieldBundle, (/dstField(i)/), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldBundleAdd(dstFieldBundleA, (/dstFieldA(i)/), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
enddo
! initialize factorList and factorIndexList
allocate(factorList(4))
allocate(factorIndexList(2,4))
factorList = (/1,2,3,4/)
factorIndexList(1,:) = (/lpe*4+1,lpe*4+2,lpe*4+3,lpe*4+4/)
factorIndexList(2,:) = (/lpe*4+1,lpe*4+2,lpe*4+3,lpe*4+4/)
call ESMF_FieldBundleSMMStore(srcFieldBundle, dstFieldBundle, routehandle, &
factorList, factorIndexList, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! perform smm
call ESMF_FieldBundleSMM(srcFieldBundleA, dstFieldBundleA, &
routehandle, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! verify smm
do l = 1, 3
call ESMF_FieldGet(dstFieldA(l), localDe=0, farrayPtr=fptr, &
exclusiveLBound=exlb, exclusiveUBound=exub, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Verify that the smm data in dstField(l) is correct.
! Before the smm op, the dst Field contains all 0.
! The smm op reset the values to the index value, verify
! this is the case.
! write(*, '(9I3)') l, lpe, fptr
do i = exlb(1), exub(1)
do j = exlb(2), exub(2)
if(fptr(i,j) .ne. j) localrc = ESMF_FAILURE
enddo
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
enddo
! release SMM route handle
call ESMF_FieldBundleSMMRelease(routehandle, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! release all acquired resources
call ESMF_FieldBundleDestroy(srcFieldBundle)
call ESMF_FieldBundleDestroy(dstFieldBundle)
call ESMF_FieldBundleDestroy(srcFieldBundleA)
call ESMF_FieldBundleDestroy(dstFieldBundleA)
do l = 1, 3
call ESMF_FieldDestroy(srcField(l))
call ESMF_FieldDestroy(dstField(l))
call ESMF_FieldDestroy(srcFieldA(l))
call ESMF_FieldDestroy(dstFieldA(l))
enddo
call ESMF_GridDestroy(grid)
call ESMF_DistGridDestroy(distgrid)
deallocate(factorList, factorIndexList)
rc = ESMF_SUCCESS
end subroutine test_smm_1dbweak
! ==================================================================================
#undef ESMF_METHOD
#define ESMF_METHOD "test_field_bundle_smm_store_from_file"
subroutine test_field_bundle_smm_store_from_file(rc, srcTermProcessing)
use ESMF_IOScripMod
integer, intent(inout) :: rc
integer, intent(inout), optional :: srcTermProcessing(:)
character(*), parameter :: weightFile = 'test_fb_weights.nc'
real, parameter :: tol = 10E-15
integer(ESMF_KIND_I4), pointer :: factorIndexList(:,:)
real(ESMF_KIND_R8), pointer :: factorList(:), coordX(:), coordY(:), &
farrayPtrMem(:, :), farrayPtrFile(:, :)
type(ESMF_Field) :: srcField, dstField, srcFields(1), dstFields(1)
type(ESMF_FieldBundle) :: srcFieldBundle, dstFieldBundle
type(ESMF_Grid) :: srcGrid, dstGrid
type(ESMF_RouteHandle) :: routehandleMem, routehandleFile
type(ESMF_Array) :: arrayMem, arrayMemCopy, arrayFile
type(ESMF_ArraySpec) :: arrayMemCopySpec
type(ESMF_DistGrid) :: arrayMemDistGrid
integer :: shp(2), ii, jj, lbnd(3), ubnd(3), countFail
rc = ESMF_FAILURE
! --------------------------------------------------------------------------------
! Generate fields for regrid store and write the factor arrays to netCDF. This
! output netCDF containing the factors is read in to test the field bundle SMM
! store from file.
srcGrid = grid_create_no_peri_dim_by_max_index((/20,40/), rc)
srcField = ESMF_FieldCreate(srcGrid, typekind=ESMF_TYPEKIND_R8, name="srcField", &
rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
dstGrid = grid_create_no_peri_dim_by_max_index((/10,20/), rc)
dstField = ESMF_FieldCreate(dstGrid, typekind=ESMF_TYPEKIND_R8, name="dstField", &
rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldFill(srcField, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldRegridStore(srcField=srcField, dstField=dstField, &
factorIndexList=factorIndexList, factorList=factorList, &
routehandle=routehandleMem, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_OutputSimpleWeightFile(weightFile, factorList, factorIndexList, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! --------------------------------------------------------------------------------
! Create field bundles and the route handle from file.
srcFields(1) = srcField
srcFieldBundle = ESMF_FieldBundleCreate(fieldList=srcFields, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
dstFields(1) = dstField
dstFieldBundle = ESMF_FieldBundleCreate(fieldList=dstFields, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
if (present(srcTermProcessing)) then
call ESMF_FieldBundleSMMStore(srcFieldBundle, dstFieldBundle, weightFile, &
routehandleFile, rc=rc, srcTermProcessing=srcTermProcessing)
else
call ESMF_FieldBundleSMMStore(srcFieldBundle, dstFieldBundle, weightFile, &
routehandleFile, rc=rc)
endif
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! --------------------------------------------------------------------------------
! Test regrid operation with original fields against factors read from file.
! The in-memory route handle.
call ESMF_FieldBundleRegrid(srcFieldBundle, dstFieldBundle, routehandleMem, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! The desired result of the from file store regrid operation.
call ESMF_FieldGet(dstField, array=arrayMem, arrayspec=arrayMemCopySpec, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! In-memory regrid operation result.
call ESMF_ArrayGet(arrayMem, distgrid=arrayMemDistGrid, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! Copy the output array from the in-memory regrid operation. The array values
! would change after the from-file regrid operation.
arrayMemCopy = ESMF_ArrayCreate(arrayMemDistGrid, arrayMemCopySpec, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_ArrayCopy(arrayMemCopy, arrayMem, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_ArrayGet(arrayMemCopy, farrayPtr=farrayPtrMem, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! The from-file route handle.
call ESMF_FieldBundleRegrid(srcFieldBundle, dstFieldBundle, routehandleFile, &
rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! The result of the from file store regrid operation.
call ESMF_FieldGet(dstField, array=arrayFile, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_ArrayGet(arrayFile, farrayPtr=farrayPtrFile, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! If the absolute value of the differences exceeds the tolerances, then the test
! will fail. The count is evaluated at the end of the subroutine.
countFail = 0
shp = shape(farrayPtrMem)
do jj=1,shp(1)
do ii=1,shp(2)
if (abs(farrayPtrMem(jj,ii) - farrayPtrFile(jj,ii)) .ge. tol) then
countFail = countFail + 1
endif
enddo
enddo
! --------------------------------------------------------------------------------
deallocate(factorList)
deallocate(factorIndexList)
call ESMF_ArrayDestroy(arrayMemCopy, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldBundleSMMRelease(routehandleMem, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldBundleDestroy(srcFieldBundle, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldBundleDestroy(dstFieldBundle, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldDestroy(srcField, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldDestroy(dstField, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_GridDestroy(srcGrid, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_GridDestroy(dstGrid, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! --------------------------------------------------------------------------------
if (countFail .eq. 0) then
rc = ESMF_SUCCESS
else
rc = ESMF_FAILURE
endif
end subroutine test_field_bundle_smm_store_from_file
! ==================================================================================
#undef ESMF_METHOD
#define ESMF_METHOD "test_field_bundle_smm_source_term_processing"
subroutine test_field_bundle_smm_source_term_processing(srcTermProcessing, rc)
integer, parameter :: fieldCount = 2
integer, parameter :: dstMaxIndex(2) = (/10, 20/)
real(ESMF_KIND_R8), parameter :: tol = 1.D-4
real(ESMF_KIND_R8) :: absDiff
integer, intent(inout) :: srcTermProcessing(:), rc
type(ESMF_Grid) :: srcGrid, dstGrid
type(ESMF_FieldBundle) :: srcFieldBundle, dstFieldBundle, desiredDstFieldBundle
type(ESMF_RouteHandle) :: routehandle
type(ESMF_Field) :: srcFieldList(fieldCount), dstFieldList(fieldCount), &
desiredDstFieldList(fieldCount)
integer(ESMF_KIND_I4), pointer :: factorIndexList(:,:)
real(ESMF_KIND_R8), pointer :: factorList(:), farrayPtrSrc(:, :), &
farrayPtrDst(:, :)
integer :: ii, jj, kk, failCount, shp(2)
character(len=160) :: msgString
! --------------------------------------------------------------------------------
! Create grids and field bundles. The source grid is slightly larger than than the
! destination ensuring no unmapped points in the destination.
srcGrid = grid_create_no_peri_dim_by_max_index((/11, 21/), rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
dstGrid = grid_create_no_peri_dim_by_max_index(dstMaxIndex, rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
srcFieldBundle = field_bundle_create(srcGrid, fieldCount, .true., rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
dstFieldBundle = field_bundle_create(dstGrid, fieldCount, .false., rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! Note fill is true in the desired destination field. This is the field we test
! regridding errors against.
desiredDstFieldBundle = field_bundle_create(dstGrid, fieldCount, .true., rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! --------------------------------------------------------------------------------
! Get access to the internal field in the bundles.
call ESMF_FieldBundleGet(srcFieldBundle, fieldList=srcFieldList, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldBundleGet(dstFieldBundle, fieldList=dstFieldList, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldBundleGet(desiredDstFieldBundle, fieldList=desiredDstFieldList, &
rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! --------------------------------------------------------------------------------
! Retrieve the factor lists from the regrid store call and use those to create a
! route handle using the provided source term processing flag.
call ESMF_FieldRegridStore(srcFieldList(1), dstFieldList(1), &
factorList=factorList, factorIndexList=factorIndexList, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldBundleSMMStore(srcFieldBundle, dstFieldBundle, routehandle, &
factorList, factorIndexList, srcTermProcessing=srcTermProcessing, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! --------------------------------------------------------------------------------
! Execute the sparse matrix multiplication the test the results against the
! desired, filled field.
call ESMF_FieldBundleSMM(srcFieldBundle, dstFieldBundle, routehandle, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
failCount = 0
do kk=1,fieldCount
call ESMF_FieldGet(dstFieldList(kk), farrayPtr=farrayPtrSrc, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_FieldGet(desiredDstFieldList(kk), farrayPtr=farrayPtrDst, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
shp = shape(farrayPtrSrc)
do ii=1,shp(1)
do jj=1,shp(2)
absDiff = abs(farrayPtrSrc(ii, jj) - farrayPtrDst(ii, jj))
if (absDiff .ge. tol) then
failCount = failCount + 1
write(msgString,*) "Absolute difference above tolerance: ", farrayPtrSrc(ii, jj), &
" - ", farrayPtrDst(ii, jj), " = ", absDiff, " > ", tol
call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO, rc=rc)
endif
enddo
enddo
enddo
! --------------------------------------------------------------------------------
! Release resources.
deallocate(factorList, factorIndexList)
call ESMF_FieldBundleSMMRelease(routehandle, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call field_bundle_destroy(srcFieldBundle, rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call field_bundle_destroy(dstFieldBundle, rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call field_bundle_destroy(desiredDstFieldBundle, rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_GridDestroy(srcGrid, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_GridDestroy(dstGrid, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
! --------------------------------------------------------------------------------
! If there are any fail counts in the field value comparisons, the test will fail.
! print *, "failCount", failCount
if (failCount .eq. 0) then
rc = ESMF_SUCCESS
else
rc = ESMF_FAILURE
endif
end subroutine test_field_bundle_smm_source_term_processing
! ==================================================================================
#undef ESMF_METHOD
#define ESMF_METHOD "grid_create_no_peri_dim_by_max_index"
type(ESMF_Grid) function grid_create_no_peri_dim_by_max_index(maxIndex, rc) &
result(grid)
integer, intent(in) :: maxIndex(2)
integer, intent(inout) :: rc
integer :: ii, lbnd(3), ubnd(3)
real(ESMF_KIND_R8), pointer :: coordX(:), coordY(:)
grid = ESMF_GridCreateNoPeriDim(maxIndex=maxIndex, coordDep1=(/1/), &
coordDep2=(/2/), rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_GridAddCoord(grid, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
call ESMF_GridGetCoord(grid, coordDim=1, computationalLBound=lbnd, &
computationalUBound=ubnd, farrayPtr=coordX, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
do ii=lbnd(1),ubnd(1)
coordX(ii) = ii*10.0
enddo
call ESMF_GridGetCoord(grid, coordDim=2, computationalLBound=lbnd, &
computationalUBound=ubnd, farrayPtr=coordY, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
do ii=lbnd(1),ubnd(1)
coordY(ii) = ii*20.0
enddo
end function grid_create_no_peri_dim_by_max_index
! ==================================================================================
#undef ESMF_METHOD
#define ESMF_METHOD "field_bundle_create"
type(ESMF_FieldBundle) function field_bundle_create(grid, fieldCount, shouldFill, &
rc) result(fieldBundle)
type(ESMF_Grid), intent(in) :: grid
integer, intent(in) :: fieldCount
integer, intent(inout) :: rc
logical, intent(in) :: shouldFill
type(ESMF_Field) :: fieldList(fieldCount), field
integer :: ii
do ii=1,fieldCount
field = ESMF_FieldCreate(grid, typekind=ESMF_TYPEKIND_R8, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
if (shouldFill) then
call ESMF_FieldFill(field, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
endif
fieldList(ii) = field
enddo
fieldBundle = ESMF_FieldBundleCreate(fieldList=fieldList, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
end function field_bundle_create
! ==================================================================================
#undef ESMF_METHOD
#define ESMF_METHOD "field_bundle_destroy"
subroutine field_bundle_destroy(fieldBundle, rc)
type(ESMF_FieldBundle), intent(inout) :: fieldBundle
integer, intent(inout) :: rc
type(ESMF_Field), allocatable :: fieldList(:)
integer :: ii, fieldCount
call ESMF_FieldBundleGet(fieldBundle, fieldCount=fieldCount, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
allocate(fieldList(fieldCount))
call ESMF_FieldBundleGet(fieldBundle, fieldList=fieldList, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
do ii=1,fieldCount
call ESMF_FieldDestroy(fieldList(ii), rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
enddo
call ESMF_FieldBundleDestroy(fieldBundle, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
line=__LINE__, file=FILENAME)) return
deallocate(fieldList)
end subroutine field_bundle_destroy
! ==================================================================================
#endif
end program ESMF_FieldBundleSMMUTest