subroutine test3(rc)
integer, intent(out) :: rc
integer :: localrc, i
type(ESMF_XGrid) :: xgrid
type(ESMF_Grid) :: sideA(2), sideB(1)
type(ESMF_DistGrid) :: sideAdg(2), sideBdg(1), distgrid
real(ESMF_KIND_R8) :: centroid(12,2), area(12)
type(ESMF_XGridSpec) :: sparseMatA2X(2), sparseMatX2B(1)
type(ESMF_Grid) :: l_sideA(2), l_sideB(1)
type(ESMF_DistGrid) :: l_sideAdg(2), l_sideBdg(1)
real(ESMF_KIND_R8) :: l_centroid(12,2), l_area(12)
type(ESMF_XGridSpec) :: l_sparseMatA2X(2), l_sparseMatX2B(1)
type(ESMF_Field) :: field, srcField(2), dstField(1)
type(ESMF_Field) :: areaField
real(ESMF_KIND_R8), pointer :: areaFptr(:)
type(ESMF_VM) :: vm
integer :: lpet, eleCount,ndim
integer :: sideAGC, sideBGC, sideAMC, sideBMC
integer :: elb, eub, ec
real(ESMF_KIND_R8), pointer :: fptr(:,:), xfptr(:)
real(ESMF_KIND_R8) :: xgrid_area(12), B_area(2,2)
integer :: xlb(1), xub(1)
type(ESMF_RouteHandle) :: rh_src2xgrid(2), rh_xgrid2dst(1)
type(ESMF_XGrid) :: xgridAlias
logical :: xgridBool
type(ESMF_CoordSys_Flag) :: coordSys
rc = ESMF_SUCCESS
localrc = ESMF_SUCCESS
call ESMF_VMGetCurrent(vm=vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, localPet=lpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
sideAdg(1) = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/2,2/), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
sideAdg(2) = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/1,2/), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
sideBdg = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/2,2/), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
do i = 1, 2
sideA(i) = ESMF_GridCreate(distgrid=sideAdg(i), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
enddo
do i = 1, 1
sideB(i) = ESMF_GridCreate(distgrid=sideBdg(i), rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
enddo
allocate(sparseMatA2X(1)%factorIndexList(2,9), sparseMatA2X(1)%factorList(9))
allocate(sparseMatA2X(2)%factorIndexList(2,3), sparseMatA2X(2)%factorList(3))
allocate(sparseMatX2B(1)%factorIndexList(2,12), sparseMatX2B(1)%factorList(12))
! factorIndexList
! setting up mapping between A1 -> X
sparseMatA2X(1)%factorIndexList(1,1)=1
sparseMatA2X(1)%factorIndexList(1,2)=2
sparseMatA2X(1)%factorIndexList(1,3)=2
sparseMatA2X(1)%factorIndexList(1,4)=3
sparseMatA2X(1)%factorIndexList(1,5)=4
sparseMatA2X(1)%factorIndexList(1,6)=4
sparseMatA2X(1)%factorIndexList(1,7)=3
sparseMatA2X(1)%factorIndexList(1,8)=4
sparseMatA2X(1)%factorIndexList(1,9)=4
sparseMatA2X(1)%factorIndexList(2,1)=1
sparseMatA2X(1)%factorIndexList(2,2)=2
sparseMatA2X(1)%factorIndexList(2,3)=3
sparseMatA2X(1)%factorIndexList(2,4)=4
sparseMatA2X(1)%factorIndexList(2,5)=5
sparseMatA2X(1)%factorIndexList(2,6)=6
sparseMatA2X(1)%factorIndexList(2,7)=7
sparseMatA2X(1)%factorIndexList(2,8)=8
sparseMatA2X(1)%factorIndexList(2,9)=9
! setting up mapping between A2 -> X
sparseMatA2X(2)%factorIndexList(1,1)=1
sparseMatA2X(2)%factorIndexList(1,2)=2
sparseMatA2X(2)%factorIndexList(1,3)=2
sparseMatA2X(2)%factorIndexList(2,1)=10
sparseMatA2X(2)%factorIndexList(2,2)=11
sparseMatA2X(2)%factorIndexList(2,3)=12
! Note that the weights are dest area weighted
! factorList
! setting up mapping between A1 -> X
sparseMatA2X(1)%factorList(1)=1
sparseMatA2X(1)%factorList(2)=1
sparseMatA2X(1)%factorList(3)=1
sparseMatA2X(1)%factorList(4)=1
sparseMatA2X(1)%factorList(5)=1
sparseMatA2X(1)%factorList(6)=1
sparseMatA2X(1)%factorList(7)=1
sparseMatA2X(1)%factorList(8)=1
sparseMatA2X(1)%factorList(9)=1
! setting up mapping between A2 -> X
sparseMatA2X(2)%factorList(1)=1
sparseMatA2X(2)%factorList(2)=1
sparseMatA2X(2)%factorList(3)=1
! factorIndexList
! setting up mapping between X -> B
sparseMatX2B(1)%factorIndexList(1,1)=1
sparseMatX2B(1)%factorIndexList(1,2)=2
sparseMatX2B(1)%factorIndexList(1,3)=3
sparseMatX2B(1)%factorIndexList(1,4)=4
sparseMatX2B(1)%factorIndexList(1,5)=5
sparseMatX2B(1)%factorIndexList(1,6)=6
sparseMatX2B(1)%factorIndexList(1,7)=7
sparseMatX2B(1)%factorIndexList(1,8)=8
sparseMatX2B(1)%factorIndexList(1,9)=9
sparseMatX2B(1)%factorIndexList(1,10)=10
sparseMatX2B(1)%factorIndexList(1,11)=11
sparseMatX2B(1)%factorIndexList(1,12)=12
sparseMatX2B(1)%factorIndexList(2,1)=1
sparseMatX2B(1)%factorIndexList(2,2)=1
sparseMatX2B(1)%factorIndexList(2,3)=2
sparseMatX2B(1)%factorIndexList(2,4)=1
sparseMatX2B(1)%factorIndexList(2,5)=1
sparseMatX2B(1)%factorIndexList(2,6)=2
sparseMatX2B(1)%factorIndexList(2,7)=3
sparseMatX2B(1)%factorIndexList(2,8)=3
sparseMatX2B(1)%factorIndexList(2,9)=4
sparseMatX2B(1)%factorIndexList(2,10)=3
sparseMatX2B(1)%factorIndexList(2,11)=3
sparseMatX2B(1)%factorIndexList(2,12)=4
! factorList
! setting up mapping between X -> B
sparseMatX2B(1)%factorList(1)=4./9
sparseMatX2B(1)%factorList(2)=2./9
sparseMatX2B(1)%factorList(3)=2./3
sparseMatX2B(1)%factorList(4)=2./9
sparseMatX2B(1)%factorList(5)=1./9
sparseMatX2B(1)%factorList(6)=1./3
sparseMatX2B(1)%factorList(7)=2./9
sparseMatX2B(1)%factorList(8)=1./9
sparseMatX2B(1)%factorList(9)=1./3
sparseMatX2B(1)%factorList(10)=4./9
sparseMatX2B(1)%factorList(11)=2./9
sparseMatX2B(1)%factorList(12)=2./3
! set up destination areas to adjust weighted flux
xgrid_area(1) = 1.
xgrid_area(2) = 0.5
xgrid_area(3) = 0.5
xgrid_area(4) = 0.5
xgrid_area(5) = 0.25
xgrid_area(6) = 0.25
xgrid_area(7) = 0.5
xgrid_area(8) = 0.25
xgrid_area(9) = 0.25
xgrid_area(10) = 1.
xgrid_area(11) = 0.5
xgrid_area(12) = 0.5
B_area(1,1) = 9./4
B_area(2,1) = 3./4
B_area(1,2) = 9./4
B_area(2,2) = 3./4
! Finally ready to do an flux exchange from A side to B side
xgrid = ESMF_XGridCreateFromSparseMat(sideAGrid=sideA, sideBGrid=sideB, &
area=xgrid_area, centroid=centroid, &
sparseMatA2X=sparseMatA2X, sparseMatX2B=sparseMatX2B, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
!------------------------------------------------------------------------
!NEX_UTest
write(name, *) "XGrid equality before assignment Test"
write(failMsg, *) "Did not return ESMF_SUCCESS"
xgridBool = (xgridAlias.eq.xgrid)
call ESMF_Test(.not.xgridBool, name, failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!NEX_UTest
! Testing ESMF_XGridAssignment(=)()
write(name, *) "XGrid assignment and equality Test"
write(failMsg, *) "Did not return ESMF_SUCCESS"
xgridAlias = xgrid
xgridBool = (xgridAlias.eq.xgrid)
call ESMF_Test(xgridBool, name, failMsg, result, ESMF_SRCLINE)
call ESMF_XGridGet(xgrid, &
sideAGridCount=sideAGC, sideBGridCount=sideBGC, &
sideAMeshCount=sideAMC, sideBMeshCount=sideBMC, &
sideAGrid=l_sideA, sideBGrid=l_sideB, area=l_area, &
coordSys=coordSys, &
elementCount=eleCount, &
centroid=l_centroid, distgridA=l_sideAdg, &
distgridM = distgrid, sparseMatA2X=l_sparseMatA2X, &
sparseMatX2B=l_sparseMatX2B, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_XGridGet(xgrid, localDe=0, elementCount=eleCount, &
exclusiveCount=ec, exclusiveLBound=elb, exclusiveUBound=eub, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
!print *, lpet, eleCount, ec, elb, eub
!call ESMF_DistGridPrint(distgrid, rc=localrc)
!if (ESMF_LogFoundError(localrc, &
! ESMF_ERR_PASSTHRU, &
! ESMF_CONTEXT, rcToReturn=rc)) return
!do i = 1, 2
! call ESMF_DistGridPrint(l_sideAdg(i), rc=localrc)
! if (ESMF_LogFoundError(localrc, &
! ESMF_ERR_PASSTHRU, &
! ESMF_CONTEXT, rcToReturn=rc)) return
!enddo
call ESMF_XGridGet(xgrid, xgridSide=ESMF_XGRIDSIDE_A, gridIndex=1, &
distgrid=distgrid, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_XGridGet(xgrid, xgridSide=ESMF_XGRIDSIDE_A, gridIndex=2, &
distgrid=distgrid, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_XGridGet(xgrid, xgridSide=ESMF_XGRIDSIDE_B, gridIndex=1, &
distgrid=distgrid, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
field = ESMF_FieldCreate(xgrid, typekind=ESMF_TYPEKIND_R8, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_XGridGetFieldBounds(xgrid, totalLBound=xlb, totalUBound=xub, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldGet(field, farrayPtr=xfptr, &
exclusiveLBound=xlb, exclusiveUBound=xub, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
xfptr = 0.0
!call ESMF_FieldPrint(field, rc=localrc)
!if (ESMF_LogFoundError(localrc, &
! ESMF_ERR_PASSTHRU, &
! ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldDestroy(field, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
!! Test ESMF_FieldRegridGetArea()
! Create Field
areaField = ESMF_FieldCreate(xgrid, typekind=ESMF_TYPEKIND_R8, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Get area
call ESMF_FieldRegridGetArea(areaField, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Get area Field
call ESMF_FieldGet(areaField, farrayPtr=areaFptr, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If the areas don't match, then complain
do i=lbound(areaFptr,1),ubound(areaFptr,1)
if (areaFptr(i) /= xgrid_area(i)) then
call ESMF_LogSetError(rcToCheck=ESMF_RC_ARG_WRONG, &
msg="creation area and retrieved area don't match.", &
ESMF_CONTEXT, rcToReturn=rc)
return
endif
enddo
! Get rid of area Field
call ESMF_FieldDestroy(areaField, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
!------------------------------------------------------------------------
!NEX_UTest
write(name, *) "XGridDestroy Test"
write(failMsg, *) "Did not return ESMF_SUCCESS"
call ESMF_XGridDestroy(xgrid, rc=rc)
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!NEX_UTest
! Testing ESMF_XGridOperator(==)()
write(name, *) "XGrid equality after destroy Test"
write(failMsg, *) "Did not return ESMF_SUCCESS"
xgridBool = (xgridAlias==xgrid)
call ESMF_Test(.not.xgridBool, name, failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!NEX_UTest
! Testing ESMF_XGridOperator(/=)()
write(name, *) "XGrid non-equality after destroy Test"
write(failMsg, *) "Did not return ESMF_SUCCESS"
xgridBool = (xgridAlias/=xgrid)
call ESMF_Test(xgridBool, name, failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!NEX_UTest
! Testing coordSys
write(name, *) "XGrid coordSys test"
write(failMsg, *) "Did not return ESMF_SUCCESS"
call ESMF_Test((coordSys .eq. ESMF_COORDSYS_SPH_DEG), name, failMsg, result, ESMF_SRCLINE)
do i = 1, 2
call ESMF_GridDestroy(sideA(i), rc = localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
enddo
do i = 1, 1
call ESMF_GridDestroy(sideB(i), rc = localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
enddo
deallocate(sparseMatA2X(1)%factorIndexList, sparseMatA2X(1)%factorList)
deallocate(sparseMatA2X(2)%factorIndexList, sparseMatA2X(2)%factorList)
deallocate(sparseMatX2B(1)%factorIndexList, sparseMatX2B(1)%factorList)
end subroutine test3