subroutine field_redist_test(PDS, test_failure, reportType, VM, rc)
!-----------------------------------------------------------------------------
! routine conducts the field redist test by redistributing from a source
! field to a destination and back again to the return field
!-----------------------------------------------------------------------------
! arguments
type(problem_descriptor_strings), intent(inout) :: PDS
character(THARN_MAXSTR), intent(in ) :: reportType
type(ESMF_VM), intent(in ) :: VM
integer, intent(inout) :: test_failure
integer, intent( out) :: rc
! local parameters
real(ESMF_KIND_R8), parameter :: initvalue = 0.0
! local ESMF Types
type(ESMF_Grid) :: gridSrc
type(ESMF_Grid) :: gridReturn
type(ESMF_Grid) :: gridDst
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: returnField
type(ESMF_ArraySpec) :: SrcArraySpec
type(ESMF_ArraySpec) :: DstArraySpec
type(ESMF_DistGrid) :: src_distgrid, dst_distgrid
type(ESMF_RouteHandle) :: routeHandle_forward
type(ESMF_RouteHandle) :: routeHandle_backward
! local integers
integer :: localrc ! local error status
integer :: iDfile, iGfile, iD, iG
integer :: test_status
integer :: localPET
! integer :: libflag
! local characters
character(THARN_MAXSTR) :: liG, liD
! debug
! real(ESMF_KIND_R8), pointer :: farrayPtr2(:,:)
! integer :: i1, i2, de, localDeCount, dimCount
! integer, allocatable :: localDeToDeMap(:)
! type(ESMF_LocalArray), allocatable :: larrayList(:)
! integer, allocatable :: LBnd(:,:), UBnd(:,:)
! type(ESMF_Index_Flag) :: indexflag
! initialize return flag
localrc = ESMF_RC_NOT_IMPL
rc = ESMF_RC_NOT_IMPL
! Setting to fail per the Don's email of 3/9/09.
test_status = HarnessTest_FAILURE
! initialize test counter
test_failure = 0
!-----------------------------------------------------------------------------
! for a single problem descriptor string, loop through each specifier file
! combination
! Create source and destination distributions, Fields and conduct regrid
!-----------------------------------------------------------------------------
print*,'-----------------======field regrid test==========-----------------------'
do iDfile=1,PDS%nDfiles ! distribution specifier files
do iGfile=1,PDS%nGfiles ! grid specifier files
do iD=1, PDS%Dfiles(iDfile)%nDspecs ! entries in distribution specifier
do iG=1, PDS%Gfiles(iGfile)%nGspecs ! entries in grid specifier file
!---------------------------------------------------------------------
! create source distribution
!---------------------------------------------------------------------
call create_distribution(PDS%SrcMem, PDS%Dfiles(iDfile)%src_dist(iD),&
PDS%Gfiles(iGfile)%src_grid(iG), src_distgrid, VM, localrc)
write(liG,"(i5)") iG
write(liD,"(i5)") iD
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"error creating source distgrid " &
// " with string " // trim(adjustL(PDS%pds)) // &
" with entry " // trim(adjustL(liD)) // " of file " // &
trim(adjustL(PDS%Dfiles(iDfile)%filename)) &
// " and entry " // trim(adjustL(liG)) // " of file " // &
trim(adjustL(PDS%Gfiles(iGfile)%filename)), &
rcToReturn=rc)) return
!---------------------------------------------------------------------
! create source grid from from distribution
!---------------------------------------------------------------------
call create_grid_from_distgrid(gridSrc, src_distgrid, PDS%SrcMem, &
PDS%Gfiles(iGfile)%src_grid(iG), &
PDS%Dfiles(iDfile)%src_dist(iD), localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"error creating source array " &
// " with string " // trim(adjustL(PDS%pds)) // &
" with entry " // trim(adjustL(liD)) // " of file " // &
trim(adjustL(PDS%Dfiles(iDfile)%filename)) &
// " and entry " // trim(adjustL(liG)) // " of file " // &
trim(adjustL(PDS%Gfiles(iGfile)%filename)), &
rcToReturn=rc)) return
!---------------------------------------------------------------------
! create array spec
!---------------------------------------------------------------------
!---------------------------------------------------------------------
! set the dimensionality of actual data storage to the memory size
! specified by the problem descriptor string
!---------------------------------------------------------------------
call ESMF_ArraySpecSet(SrcArraySpec, typekind=ESMF_TYPEKIND_R8, &
rank=PDS%SrcMem%memRank, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"error creating ArraySpecSet", &
rcToReturn=rc)) return
!---------------------------------------------------------------------
! create source field from grid and arrayspec
!---------------------------------------------------------------------
srcField = ESMF_FieldCreate(grid=gridSrc, arrayspec=SrcArraySpec, &
staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"error creating source field", &
rcToReturn=rc)) return
!---------------------------------------------------------------------
! populate src field with test function for regridding test
!---------------------------------------------------------------------
!!!! need to populate as in array redist test
!---------------------------------------------------------------------
! create return field from grid and arrayspec
!---------------------------------------------------------------------
returnField = ESMF_FieldCreate(grid=gridReturn, arrayspec=SrcArraySpec, &
staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"error creating source field", &
rcToReturn=rc)) return
!-------------------------------------------------------------------------------
! Destination
!-------------------------------------------------------------------------------
!---------------------------------------------------------------------
! Create Destination distribution
!---------------------------------------------------------------------
call create_distribution(PDS%DstMem, PDS%Dfiles(iDfile)%dst_dist(iD),&
PDS%Gfiles(iGfile)%dst_grid(iG), dst_distgrid, VM, localrc)
write(liG,"(i5)") iG
write(liD,"(i5)") iD
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"error creating source distgrid " &
// " with string " // trim(adjustL(PDS%pds)) // &
" with entry " // trim(adjustL(liD)) // " of file " // &
trim(adjustL(PDS%Dfiles(iDfile)%filename)) &
// " and entry " // trim(adjustL(liG)) // " of file " // &
trim(adjustL(PDS%Gfiles(iGfile)%filename)), &
rcToReturn=rc)) return
!---------------------------------------------------------------------
! create destination grid from from distribution
!---------------------------------------------------------------------
call create_grid_from_distgrid(gridDst, dst_distgrid, PDS%DstMem, &
PDS%Gfiles(iGfile)%dst_grid(iG), &
PDS%Dfiles(iDfile)%src_dist(iD), localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"error creating source array " &
// " with string " // trim(adjustL(PDS%pds)) // &
" with entry " // trim(adjustL(liD)) // " of file " // &
trim(adjustL(PDS%Dfiles(iDfile)%filename)) &
// " and entry " // trim(adjustL(liG)) // " of file " // &
trim(adjustL(PDS%Gfiles(iGfile)%filename)), &
rcToReturn=rc)) return
!---------------------------------------------------------------------
! create array spec
!---------------------------------------------------------------------
!---------------------------------------------------------------------
! set the dimensionality of actual data storage to the memory size
! specified by the problem descriptor string
!---------------------------------------------------------------------
call ESMF_ArraySpecSet(DstArraySpec, typekind=ESMF_TYPEKIND_R8, &
rank=PDS%DstMem%memRank, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"error creating dst ArraySpecSet", &
rcToReturn=rc)) return
!---------------------------------------------------------------------
! create source field from grid and arrayspec
!---------------------------------------------------------------------
dstField = ESMF_FieldCreate(gridDst, DstArraySpec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"error creating dst field", &
rcToReturn=rc)) return
!-----------------------------------------------------------------------------
! Now conduct the forward redist test
!-----------------------------------------------------------------------------
! forward redist
call ESMF_FieldRedistStore(srcField, dstField, routeHandle_forward, &
rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"Field Redist " // &
"store failed", rcToReturn=rc)) return
!---------------------------------------------------------------------
! redist run
!---------------------------------------------------------------------
call ESMF_FieldRedist(srcField, dstField, routeHandle_forward, &
rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"Field Redist run failed for " // &
" forward failed ", rcToReturn=rc)) return
!-----------------------------------------------------------------------------
! backward redist
!-----------------------------------------------------------------------------
call ESMF_FieldRedistStore(dstField, returnField, &
routeHandle_backward, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"Field Redist " // &
"store failed", rcToReturn=rc)) return
!---------------------------------------------------------------------
! redist run
!---------------------------------------------------------------------
call ESMF_FieldRedist(dstField, returnField, routeHandle_backward, &
rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"Field Redist run failed for " // &
" backward failed ", rcToReturn=rc)) return
!-----------------------------------------------------------------------------
! Check redistribution
!-----------------------------------------------------------------------------
!---------------------------------------------------------------------
!---------------------------------------------------------------------
!!!!! to do: check the redist - should be similar to the array redist check
!!!!! except that you need to extract the values from a field rather than an array
PDS%test_record(iDfile,iGfile)%test_status(iD,iG) = test_status
if( test_status == HarnessTest_FAILURE ) then
test_failure = test_failure + 1
endif
call ESMF_VMGet(VM, localPet=localPET, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"can not get local pet ", &
rcToReturn=rc)) return
call report_descriptor_string(PDS, iG, iD, iGfile, iDfile, &
reportType, localPET, localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"redistribution array " // &
" test report failed ", rcToReturn=rc)) return
!-----------------------------------------------------------------------------
! Clean up!!!
!-----------------------------------------------------------------------------
!---------------------------------------------------------------------
! release handles
!---------------------------------------------------------------------
call ESMF_FieldRegridRelease(routeHandle_forward, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"Regrid routehandle Release failed",&
rcToReturn=rc)) return
call ESMF_FieldRegridRelease(routeHandle_backward, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"Regrid routehandle Release failed",&
rcToReturn=rc)) return
!---------------------------------------------------------------------
! release Fields
!---------------------------------------------------------------------
call ESMF_FieldDestroy(srcField, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"SRC Field Regrid Release failed", &
rcToReturn=rc)) return
call ESMF_FieldDestroy(returnField, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"Return Field Regrid Release failed", &
rcToReturn=rc)) return
call ESMF_FieldDestroy(dstField, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"DST Field Regrid Release failed", &
rcToReturn=rc)) return
!---------------------------------------------------------------------
! release Grids
!---------------------------------------------------------------------
call ESMF_GridDestroy(gridSrc, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"SRC grid Release failed", &
rcToReturn=rc)) return
call ESMF_GridDestroy(gridDst, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"DST Grid Release failed", &
rcToReturn=rc)) return
!---------------------------------------------------------------------
! Destroy DistGrid objects before running next test
!---------------------------------------------------------------------
call ESMF_DistGridDestroy(src_distgrid, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"unable to destroy src_distgrid", &
rcToReturn=rc)) return
call ESMF_DistGridDestroy(dst_distgrid, rc=localrc)
if (CheckError(checkpoint, __LINE__, __FILE__, localrc,"unable to destroy src_distgrid", &
rcToReturn=rc)) return
!---------------------------------------------------------------------
enddo ! iG
enddo ! iD
enddo ! iGfile
enddo ! iDfile
!-----------------------------------------------------------------------------
! if I've gotten this far without an error, then the routine has succeeded.
!-----------------------------------------------------------------------------
rc = ESMF_SUCCESS
print*,'Field Redist Completed'
!-----------------------------------------------------------------------------
end subroutine field_redist_test