program ESMF_FieldRegridCsrvUTest
!------------------------------------------------------------------------------
#include "ESMF.h"
!==============================================================================
!BOPI
! !PROGRAM: ESMF_FieldRegridCsrvUTest - Unit tests for conservative Field Regrid methods
!
! !DESCRIPTION:
!
! The code in this file drives F90 conservative Field Regrid unit tests.
!
!EOPI
!-----------------------------------------------------------------------------
! !USES:
use ESMF_TestMod ! test methods
use ESMF
use ESMF_GridUtilMod
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 = 1
logical :: itrp = .false.
logical :: csrv = .false.
! individual test failure message
character(ESMF_MAXSTR) :: failMsg
character(512) :: name
call ESMF_TestStart(ESMF_SRCLINE, rc=rc)
if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT)
#ifdef ESMF_TESTEXHAUSTIVE
! This #if surrounds all the tests to enable turning on just one test
#if 1
!------------------------------------------------------------------------
!------------------------------------------------------------------------
! Test conservative regridding between 2 spherical grids
! initialize
rc=ESMF_SUCCESS
! do test
call test_csrvregrid(itrp, csrv, rc)
!------------------------------------------------------------------------
! Check return code
!EX_UTest
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a sphere"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
! Check interp error
!EX_UTest
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a sphere interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
! Check conserve error
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a sphere conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!------------------------------------------------------------------------
! Test MOAB conservative regridding between 2 spherical grids
! initialize
rc=ESMF_SUCCESS
itrp = .true.
csrv = .true.
#if defined ESMF_MOAB
! Turn on MOAB
call ESMF_MeshSetMOAB(.true.)
! do test
call test_csrvregrid(itrp, csrv, rc)
! Turn off MOAB
call ESMF_MeshSetMOAB(.false.)
#endif
!------------------------------------------------------------------------
! Check return code
!EX_UTest
write(failMsg, *) "Returned an error"
write(name, *) "MOAB Conservative regridding between spherical Grids"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
! Check interp error
!EX_UTest
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "MOAB Conservative regridding on a sphere interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
! Check conserve error
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "MOAB Conservative regridding on a sphere conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!------------------------------------------------------------------------
! Test conservative regridding between 2 spherical grids with masks
! initialize
rc=ESMF_SUCCESS
! do test
call test_csrvregridWMasks(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a sphere with masks"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a sphere with masks interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a sphere with masks conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!------------------------------------------------------------------------
! Test conservative regridding between 2 Cart. Grids with masks
! initialize
rc=ESMF_SUCCESS
itrp = .true.
csrv = .true.
! do test
call test_cartcsrvregridWMasks(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a Cartesian Grid with masks"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a Cartesian Grid with masks interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a Cartesian Grid with Masks conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!------------------------------------------------------------------------
! Test MOAB conservative regridding between 2 Cart. Grids with masks
! initialize
rc=ESMF_SUCCESS
itrp = .true.
csrv = .true.
#if defined ESMF_MOAB
! Turn on MOAB
call ESMF_MeshSetMOAB(.true.)
! do test
call test_cartcsrvregridWMasks(itrp, csrv, rc)
! Turn off MOAB
call ESMF_MeshSetMOAB(.false.)
#endif
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "MOAB Conservative regridding on a Cartesian Grid with masks"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "MOAB Conservative regridding on a Cartesian Grid with masks interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "MOAB Conservative regridding on a Cartesian Grid with Masks conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!------------------------------------------------------------------------
! do test
rc=ESMF_SUCCESS
! do test
call test_3DcartcsrvregridWMasks(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a 3D cartesian grid with masks"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a 3D cartesian grid with masks interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a 3D cartesian grid with Masks conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
! do test
rc=ESMF_SUCCESS
call test_RegridCsrv3DCartMesh(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a 3D cartesian Mesh"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a 3D cartesian Mesh interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a 3D cartesian Mesh conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
! initialize
rc=ESMF_SUCCESS
! do test
call test_csrvregridWMasksUserArea(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a sphere with user areas"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a sphere with user areas: interpolation error"
! return result
call ESMF_Test((itrp .eqv. .true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a sphere with user areas: conservation error"
! return result
call ESMF_Test((csrv .eqv. .true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!------------------------------------------------------------------------
! Test conservative regridding between 2 Cart. meshes containing cells with >4 sides
! initialize
rc=ESMF_SUCCESS
itrp = .true.
csrv = .true.
! do test
call test_RegridCsrvCartPHMesh(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a Mesh with a pentagon and hexagon"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a Mesh with a pentagon and hexagon", &
" interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a Mesh with a pentagon and hexagon", &
" conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!------------------------------------------------------------------------
! Test MOAB conservative regridding between 2 Cart. meshes containing cells with >4 sides
! initialize
rc=ESMF_SUCCESS
itrp = .true.
csrv = .true.
#if defined ESMF_MOAB
! Turn on MOAB
call ESMF_MeshSetMOAB(.true.)
! do test
call test_RegridCsrvCartMesh(itrp, csrv, rc)
! Turn off MOAB
call ESMF_MeshSetMOAB(.false.)
#endif
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "MOAB conservative regridding on a Cart. Mesh with masks and fracs."
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "MOAB conservative regridding on a Cart. Mesh with masks and fracs.", &
" interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "MOAB conservative regridding on a Cart. Mesh with masks and fracs.", &
" conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!------------------------------------------------------------------------
!!! Test frac norm option
rc=ESMF_SUCCESS ! initialize
call test_sph_csrv_w_frac_norm(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a sphere with frac norm option"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a sphere with frac norm option: interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a sphere with frac norm option: conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
! initialize
rc=ESMF_SUCCESS
! do test
call test_RegridCsrvCartPHFracNorm(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a pentagon and hexagon with frac norm"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a pentagon and hexagon with frac norm:", &
" interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a pentagon and hexagon with frac norm:", &
" conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!==========================================================================
! initialize
rc=ESMF_SUCCESS
! do test
call test_RegridCart4ConcaveMesh(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a Cart. Mesh with a concave quad."
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a Cart. Mesh with a concave quad.", &
" interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a Cart. Mesh with a concave quad.", &
" conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!============== Concave Cart Mesh =======================================
! initialize
rc=ESMF_SUCCESS
! do test
call test_RegridCart4ConcaveMesh(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a Cart. Mesh with a concave quad."
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a Cart. Mesh with a concave quad.", &
" interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a Cart. Mesh with a concave quad.", &
" conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!============== Concave Sph Mesh =======================================
! initialize
rc=ESMF_SUCCESS
! do test
call test_RegridSph4ConcaveMesh(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a Sph. Mesh with a concave quad."
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a Sph. Mesh with a concave quad.", &
" interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a sph. Mesh with a concave quad.", &
" conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!============== MOAB Mesh to Mesh =======================================
! initialize
rc=ESMF_SUCCESS
#if defined ESMF_MOAB
call test_MOABMeshToMesh(itrp, csrv, rc)
#else
itrp = .true.
csrv = .true.
#endif
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding MOAB Mesh to Mesh."
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding MOAB Mesh to Mesh.", &
" interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding MOAB Mesh to Mesh.", &
" conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!============== MultiPoly =======================================
! initialize
rc=ESMF_SUCCESS
! do test
call test_RegridCsrvCartMultiPoly(itrp, csrv, rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a Mesh with a multipolygon"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a Mesh with a multipolygon", &
" interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a Mesh with a multipolygon", &
" conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!============== 2 Tile =======================================
! initialize
rc=ESMF_SUCCESS
! do test
call test_regrid2TileDG(itrp,csrv,rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on a 2 tile Grid"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on a 2 tile Grid", &
" interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on a 2 tile Grid", &
" conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!============== Mesh Easy Elems =======================================
! initialize
rc=ESMF_SUCCESS
! do test
call test_MeshEasyElems(itrp,csrv,rc)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Returned an error"
write(name, *) "Conservative regridding on an easy elems Mesh"
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding interpolation
write(failMsg, *) "Interpolation maximum error is greater than 10^-2"
write(name, *) "Conservative regridding on an easy elems Mesh", &
" interpolation error"
! return result
call ESMF_Test((itrp.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
! Test conservative regridding conservation
write(failMsg, *) "Conservation relative error is greater than 10^-12"
write(name, *) "Conservative regridding on an easy elems Mesh", &
" conservation error"
! return result
call ESMF_Test((csrv.eqv..true. .and. rc.eq.ESMF_SUCCESS), name, &
failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
write(failMsg, *) "Test unsuccessful"
write(name, *) "Test ignoreDegenerate"
! initialize
rc=ESMF_SUCCESS
! do test
call test_ignoreDegenerate(rc)
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
write(failMsg, *) "Test unsuccessful"
write(name, *) "Test per location regrid status output"
! initialize
rc=ESMF_SUCCESS
! do test
call test_regridPerLocStatus(rc)
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!EX_UTest
write(failMsg, *) "Test unsuccessful"
write(name, *) "Test conservative regridding of disjoint meshes"
! initialize
rc=ESMF_SUCCESS
! do test
call test_regridDisjoint(rc)
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
!------------------------------------------------------------------------
!EX_UTest
write(failMsg, *) "Test unsuccessful"
write(name, *) "Test overlap error checking"
! initialize
rc=ESMF_SUCCESS
! do test
call test_overlap_error(rc)
! return result
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)
!------------------------------------------------------------------------
#endif
#endif
call ESMF_TestEnd(ESMF_SRCLINE)
contains
#define ESMF_METHOD "test_csrvregrid"
subroutine test_csrvregrid(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Grid) :: srcGrid
type(ESMF_Grid) :: dstGrid
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: errorField
type(ESMF_Field) :: srcArea, dstArea
type(ESMF_Array) :: dstArray
type(ESMF_Array) :: xdstArray
type(ESMF_Array) :: errorArray
type(ESMF_Array) :: srcArray
type(ESMF_Array) :: srcAreaArray, dstAreaArray
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: farrayPtrXC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtrYC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtr(:,:),xfarrayPtr(:,:),errorfarrayPtr(:,:),iwtsptr(:,:)
real(ESMF_KIND_R8), pointer :: srcAreaptr(:,:), dstAreaptr(:,:)
integer :: petMap2D(2,2,1)
integer :: clbnd(2),cubnd(2)
integer :: fclbnd(2),fcubnd(2)
integer :: i1,i2, index(2)
integer :: lDE, localDECount, i
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
integer :: Src_nx, Src_ny
integer :: Dst_nx, Dst_ny
real(ESMF_KIND_R8) :: Src_dx, Src_dy, yp1
real(ESMF_KIND_R8) :: Dst_dx, Dst_dy
real(ESMF_KIND_R8) :: ctheta, stheta
real(ESMF_KIND_R8) :: theta, d2rad, x, y, z
real(ESMF_KIND_R8) :: DEG2RAD, a, lat, lon, phi
real(ESMF_KIND_R8) :: xtmp, ytmp, ztmp
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
integer :: spherical_grid
integer, pointer :: larrayList(:)
integer :: localPet, petCount
! result code
integer :: finalrc
! init success flag
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Establish the resolution of the grids
Src_nx = 180
Src_ny = 100
! Src_nx = 360
! Src_ny = 180
Src_dx = 360.0/Src_nx
Src_dy = 180.0/Src_ny
Dst_nx = 100
Dst_ny = 80
! Dst_nx = 144
! Dst_ny = 72
Dst_dx = 360.0/Dst_nx
Dst_dy = 180.0/Dst_ny
! degree to rad conversion
DEG2RAD = 3.141592653589793_ESMF_KIND_R8/180.0_ESMF_KIND_R8
! setup source grid
srcGrid=ESMF_GridCreate1PeriDim(minIndex=(/1,1/),maxIndex=(/src_nx,src_ny/),regDecomp=(/petCount,1/), &
! coordSys=ESMF_COORDSYS_SPH_DEG, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! setup dest. grid
dstGrid=ESMF_GridCreate1PeriDim(minIndex=(/1,1/),maxIndex=(/dst_nx,dst_ny/),regDecomp=(/1,petCount/), &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source/destination fields
call ESMF_ArraySpecSet(arrayspec, 2, ESMF_TYPEKIND_R8, rc=rc)
srcField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcArea = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
errorField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
xdstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstArea = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Allocate coordinates
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get number of local DEs
call ESMF_GridGet(srcGrid, localDECount=localDECount, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get arrays
! dstArray
call ESMF_FieldGet(dstField, array=dstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! srcArray
call ESMF_FieldGet(srcField, array=srcArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! xdstArray
call ESMF_FieldGet(xdstField, array=xdstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! errorArray
call ESMF_FieldGet(errorField, array=errorArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(srcArea, array=srcAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(dstArea, array=dstAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Source Grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Construct 3D Grid A
! (Get memory and set coords for src)
do lDE=0,localDECount-1
!! get coord 1
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! write(*,*) "A Corner: x=[",clbnd(1),cubnd(1),"] y=[",clbnd(2),cubnd(2),"]"
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Src_dx
farrayPtrYC(i1,i2) = REAL(i2-1)*Src_dy - 90.0
enddo
enddo
!! DO CENTER STAGGER STUFF
!! get coord 1
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src pointer
call ESMF_FieldGet(srcField, lDE, farrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
y= REAL(i2-1)*Src_dy - 90.0
yp1= REAL(i2-1+1)*Src_dy - 90.0
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Src_dx + 0.5*Src_dx
farrayPtrYC(i1,i2) = (y+yp1)/2.0
! set src data
lon = farrayPtrXC(i1,i2)
lat = farrayPtrYC(i1,i2)
! Set the source to be a function of the x,y,z coordinate
theta = DEG2RAD*(lon)
phi = DEG2RAD*(90.-lat)
! set src data
!farrayPtr(i1,i2) = 1.
farrayPtr(i1,i2) = 2. + cos(theta)**2.*cos(2.*phi)
enddo
enddo
enddo ! lDE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Destination grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Get memory and set coords for dst
do lDE=0,localDECount-1
!! get coords
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set dest coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Dst_dx
farrayPtrYC(i1,i2) = REAL(i2-1)*Dst_dy - 90.0
enddo
enddo
!! DO CENTER STAGGER STUFF
!! get coord 1
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst pointer
call ESMF_FieldGet(dstField, lDE, farrayPtr, computationalLBound=fclbnd, &
computationalUBound=fcubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact pointer
call ESMF_FieldGet(xdstField, lDE, xfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
y= REAL(i2-1)*Dst_dy - 90.0
yp1= REAL(i2-1+1)*Dst_dy - 90.0
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Dst_dx + 0.5*Dst_dx
farrayPtrYC(i1,i2) = (y+yp1)/2.0
! init dst data
farrayPtr(i1,i2) = 0.0
! init exact answer
lon = farrayPtrXC(i1,i2)
lat = farrayPtrYC(i1,i2)
! Set the source to be a function of the x,y,z coordinate
theta = DEG2RAD*(lon)
phi = DEG2RAD*(90.-lat)
! set exact dst data
xfarrayPtr(i1,i2) = 2. + cos(theta)**2.*cos(2.*phi)
enddo
enddo
enddo ! lDE
#if 0
call ESMF_GridWriteVTK(dstGrid,staggerloc=ESMF_STAGGERLOC_CORNER, &
isSphere=.true., isLatLonDeg=.true., filename="dstGrid", &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
#endif
! Regrid store
call ESMF_FieldRegridStore(srcField, &
dstField=dstField, &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
checkFlag=.true., & ! Add this to make sure it doesn't cause problems
! even when no error
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
do lDE=0,localDECount-1
! get src Field
call ESMF_FieldGet(dstField, lDE, farrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src destination Field
call ESMF_FieldGet(xdstField, lDE, xfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(errorField, lDE, errorfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(dstArea, lDE, dstAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
dstmass = 0.
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
if (xfarrayPtr(i1,i2) .ne. 0.0) then
errorfarrayPtr(i1,i2)=ABS(farrayPtr(i1,i2) - xfarrayPtr(i1,i2))/ABS(xfarrayPtr(i1,i2))
error = error + errorfarrayPtr(i1,i2)
if (errorfarrayPtr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfarrayPtr(i1,i2)
endif
if (errorfarrayPtr(i1,i2) < minerror(1)) then
minerror(1) = errorfarrayPtr(i1,i2)
endif
else
errorfarrayPtr(i1,i2)=ABS(farrayPtr(i1,i2) - xfarrayPtr(i1,i2))
error = error + errorfarrayPtr(i1,i2)
if (errorfarrayPtr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfarrayPtr(i1,i2)
endif
if (errorfarrayPtr(i1,i2) < minerror(1)) then
minerror(1) = errorfarrayPtr(i1,i2)
endif
endif
dstmass = dstmass + dstAreaptr(i1,i2)*farrayPtr(i1,i2)
enddo
enddo
enddo ! lDE
srcmass(1) = 0.
do lDE=0,localDECount-1
! get src pointer
call ESMF_FieldGet(srcField, lDE, farrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcArea, lDE, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
srcmass(1) = srcmass(1) + srcAreaptr(i1,i2)*farrayPtr(i1,i2)
enddo
enddo
enddo ! lDE
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Spherical grids ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
#if 0
spherical_grid = 1
call ESMF_MeshIO(vm, srcGrid, ESMF_STAGGERLOC_CENTER, &
"srcmesh", srcArray, srcAreaArray, rc=localrc, &
spherical=spherical_grid)
call ESMF_MeshIO(vm, dstGrid, ESMF_STAGGERLOC_CENTER, &
"dstmesh", dstArray, xdstArray, errorArray, dstAreaarray, rc=localrc, &
spherical=spherical_grid)
#endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(errorField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the grids
call ESMF_GridDestroy(srcGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridDestroy(dstGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
end subroutine test_csrvregrid
subroutine test_csrvregridwmasks(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Grid) :: srcGrid
type(ESMF_Grid) :: dstGrid
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: dstFracField
type(ESMF_Field) :: srcFracField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: errorField
type(ESMF_Field) :: srcArea, dstArea
type(ESMF_Array) :: dstArray
type(ESMF_Array) :: xdstArray
type(ESMF_Array) :: errorArray
type(ESMF_Array) :: srcArray
type(ESMF_Array) :: srcAreaArray, dstAreaArray
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
integer(ESMF_KIND_I4), pointer :: srcMask(:,:), dstMask(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtrXC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtrYC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtr(:,:),xfarrayPtr(:,:),errorfarrayPtr(:,:),iwtsptr(:,:)
real(ESMF_KIND_R8), pointer :: srcAreaptr(:,:), dstAreaptr(:,:)
real(ESMF_KIND_R8), pointer :: srcFracptr(:,:), dstFracptr(:,:)
integer :: petMap2D(2,2,1)
integer :: clbnd(2),cubnd(2)
integer :: fclbnd(2),fcubnd(2)
integer :: i1,i2, index(2)
integer :: lDE, localDECount, i
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
integer :: Src_nx, Src_ny
integer :: Dst_nx, Dst_ny
real(ESMF_KIND_R8) :: Src_dx, Src_dy, yp1
real(ESMF_KIND_R8) :: Dst_dx, Dst_dy
real(ESMF_KIND_R8) :: ctheta, stheta
real(ESMF_KIND_R8) :: theta, d2rad, x, y, z
real(ESMF_KIND_R8) :: DEG2RAD, a, lat, lon, phi
real(ESMF_KIND_R8) :: xtmp, ytmp, ztmp
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
integer :: spherical_grid
integer, pointer :: larrayList(:)
integer :: localPet, petCount
! result code
integer :: finalrc
! init success flag
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Establish the resolution of the grids
Src_nx = 180
Src_ny = 100
Src_dx = 360.0/Src_nx
Src_dy = 180.0/Src_ny
Dst_nx = 100
Dst_ny = 80
Dst_dx = 360.0/Dst_nx
Dst_dy = 180.0/Dst_ny
! degree to rad conversion
DEG2RAD = 3.141592653589793_ESMF_KIND_R8/180.0_ESMF_KIND_R8
! setup source grid
srcGrid=ESMF_GridCreate1PeriDim(minIndex=(/1,1/),maxIndex=(/src_nx,src_ny/),regDecomp=(/petCount,1/), &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! setup dest. grid
dstGrid=ESMF_GridCreate1PeriDim(minIndex=(/1,1/),maxIndex=(/dst_nx,dst_ny/),regDecomp=(/1,petCount/), &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source/destination fields
call ESMF_ArraySpecSet(arrayspec, 2, ESMF_TYPEKIND_R8, rc=rc)
srcField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcFracField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcArea = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
errorField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstFracField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
xdstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstArea = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Allocate coordinates
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Add Masks
call ESMF_GridAddItem(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddItem(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get number of local DEs
call ESMF_GridGet(srcGrid, localDECount=localDECount, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get arrays
! dstArray
call ESMF_FieldGet(dstField, array=dstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! srcArray
call ESMF_FieldGet(srcField, array=srcArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! xdstArray
call ESMF_FieldGet(xdstField, array=xdstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! errorArray
call ESMF_FieldGet(errorField, array=errorArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(srcArea, array=srcAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(dstArea, array=dstAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Source Grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Construct 3D Grid A
! (Get memory and set coords for src)
do lDE=0,localDECount-1
!! get coord 1
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Src_dx
farrayPtrYC(i1,i2) = REAL(i2-1)*Src_dy - 90.0
enddo
enddo
!! DO CENTER STAGGER STUFF
!! get coord 1
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src pointer
call ESMF_FieldGet(srcField, lDE, farrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetItem(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=srcMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
y= REAL(i2-1)*Src_dy - 90.0
yp1= REAL(i2-1+1)*Src_dy - 90.0
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Src_dx + 0.5*Src_dx
farrayPtrYC(i1,i2) = (y+yp1)/2.0
! set src data
lon = farrayPtrXC(i1,i2)
lat = farrayPtrYC(i1,i2)
! Set the source to be a function of the x,y,z coordinate
theta = DEG2RAD*(lon)
phi = DEG2RAD*(90.-lat)
! set src data
! farrayPtr(i1,i2) = 1.
farrayPtr(i1,i2) = 2. + cos(theta)**2.*cos(2.*phi)
if ((lat>-45) .and. (lat<45)) then
srcMask(i1,i2)=1
else
srcMask(i1,i2)=0
endif
enddo
enddo
enddo ! lDE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Destination grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Get memory and set coords for dst
do lDE=0,localDECount-1
!! get coords
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set dest coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Dst_dx
farrayPtrYC(i1,i2) = REAL(i2-1)*Dst_dy - 90.0
enddo
enddo
!! DO CENTER STAGGER STUFF
!! get coord 1
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=dstMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst pointer
call ESMF_FieldGet(dstField, lDE, farrayPtr, computationalLBound=fclbnd, &
computationalUBound=fcubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact pointer
call ESMF_FieldGet(xdstField, lDE, xfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
y= REAL(i2-1)*Dst_dy - 90.0
yp1= REAL(i2-1+1)*Dst_dy - 90.0
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Dst_dx + 0.5*Dst_dx
farrayPtrYC(i1,i2) = (y+yp1)/2.0
! init dst data
farrayPtr(i1,i2) = 0.0
! init exact answer
lon = farrayPtrXC(i1,i2)
lat = farrayPtrYC(i1,i2)
! Set the source to be a function of the x,y,z coordinate
theta = DEG2RAD*(lon)
phi = DEG2RAD*(90.-lat)
! set exact dst data
xfarrayPtr(i1,i2) = 2. + cos(theta)**2.*cos(2.*phi)
! xfarrayPtr(i1,i2) = 1.0
if ((lon>-45) .and. (lon<45)) then
dstMask(i1,i2)=1
else
dstMask(i1,i2)=0
endif
enddo
enddo
enddo ! lDE
! Regrid store
call ESMF_FieldRegridStore(srcField, srcMaskValues=(/1/), &
dstField=dstField, dstMaskValues=(/1/), &
routeHandle=routeHandle, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
do lDE=0,localDECount-1
! get dst Field
call ESMF_FieldGet(dstField, lDE, farrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, lDE, xfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get destination mask field
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=dstMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get error Field
call ESMF_FieldGet(errorField, lDE, errorfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstArea, lDE, dstAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, lDE, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
dstmass = 0.
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! skip if masked
if (dstMask(i1,i2) .eq. 1) cycle
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1,i2)*farrayPtr(i1,i2)
! Instead do this
dstmass = dstmass + dstAreaptr(i1,i2)*farrayPtr(i1,i2)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
! if (dstFracptr(i1,i2) .lt. 0.999) cycle
if (dstFracptr(i1,i2) .lt. 0.001) cycle
if (xfarrayPtr(i1,i2) .ne. 0.0) then
errorfarrayPtr(i1,i2)=ABS((farrayPtr(i1,i2)/dstFracPtr(i1,i2)) &
- xfarrayPtr(i1,i2))/ABS(xfarrayPtr(i1,i2))
error = error + errorfarrayPtr(i1,i2)
if (errorfarrayPtr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfarrayPtr(i1,i2)
endif
if (errorfarrayPtr(i1,i2) < minerror(1)) then
minerror(1) = errorfarrayPtr(i1,i2)
endif
else
errorfarrayPtr(i1,i2)=ABS((farrayPtr(i1,i2)/dstFracPtr(i1,i2)) - xfarrayPtr(i1,i2))
error = error + errorfarrayPtr(i1,i2)
if (errorfarrayPtr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfarrayPtr(i1,i2)
endif
if (errorfarrayPtr(i1,i2) < minerror(1)) then
minerror(1) = errorfarrayPtr(i1,i2)
endif
endif
enddo
enddo
enddo ! lDE
srcmass(1) = 0.
do lDE=0,localDECount-1
! get src pointer
call ESMF_FieldGet(srcField, lDE, farrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcArea, lDE, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, lDE, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
srcmass(1) = srcmass(1) + srcFracptr(i1,i2)*srcAreaptr(i1,i2)*farrayPtr(i1,i2)
enddo
enddo
enddo ! lDE
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Spherical grids with masks ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
#if 0
spherical_grid = 1
call ESMF_MeshIO(vm, srcGrid, ESMF_STAGGERLOC_CENTER, &
"srcmesh", srcArray, srcAreaArray, rc=localrc, &
spherical=spherical_grid)
call ESMF_MeshIO(vm, dstGrid, ESMF_STAGGERLOC_CENTER, &
"dstmesh", dstArray, xdstArray, errorArray, dstAreaarray, rc=localrc, &
spherical=spherical_grid)
#endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(errorField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the grids
call ESMF_GridDestroy(srcGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridDestroy(dstGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
end subroutine test_csrvregridwmasks
subroutine test_cartcsrvregridwmasks(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Grid) :: srcGrid
type(ESMF_Grid) :: dstGrid
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: dstFracField
type(ESMF_Field) :: srcFracField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: errorField
type(ESMF_Field) :: srcArea, dstArea
type(ESMF_Array) :: dstArray
type(ESMF_Array) :: xdstArray
type(ESMF_Array) :: errorArray
type(ESMF_Array) :: srcArray
type(ESMF_Array) :: srcAreaArray, dstAreaArray
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
integer(ESMF_KIND_I4), pointer :: srcMask(:,:), dstMask(:,:)
real(ESMF_KIND_R8), pointer :: fptrXC(:,:)
real(ESMF_KIND_R8), pointer :: fptrYC(:,:)
real(ESMF_KIND_R8), pointer :: fptr(:,:),xfptr(:,:),errorfptr(:,:),iwtsptr(:,:)
real(ESMF_KIND_R8), pointer :: srcAreaptr(:,:), dstAreaptr(:,:)
real(ESMF_KIND_R8), pointer :: srcFracptr(:,:), dstFracptr(:,:)
integer :: petMap2D(2,2,1)
integer :: clbnd(2),cubnd(2)
integer :: fclbnd(2),fcubnd(2)
integer :: i1,i2, index(2)
integer :: lDE, localDECount, i
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
integer :: Src_nx, Src_ny
integer :: Dst_nx, Dst_ny
real(ESMF_KIND_R8) :: x,y
real(ESMF_KIND_R8) :: cnr_x,cnr_xp1,cnr_y,cnr_yp1
real(ESMF_KIND_R8) :: Src_dx, Src_dy
real(ESMF_KIND_R8) :: Dst_dx, Dst_dy
real(ESMF_KIND_R8) :: Src_minx, Src_miny
real(ESMF_KIND_R8) :: Src_maxx, Src_maxy
real(ESMF_KIND_R8) :: Dst_minx, Dst_miny
real(ESMF_KIND_R8) :: Dst_maxx, Dst_maxy
real(ESMF_KIND_R8) :: ctheta, stheta
real(ESMF_KIND_R8) :: xtmp, ytmp, ztmp
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
integer :: spherical_grid
integer, pointer :: larrayList(:)
integer :: localPet, petCount
! result code
integer :: finalrc
! init success flag
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Establish the resolution of the grids
Src_nx = 30
Src_ny = 30
Src_minx=0.0
Src_miny=0.0
Src_maxx=10.0
Src_maxy=10.0
Dst_nx = 20
Dst_ny = 20
Dst_minx=0.0
Dst_miny=0.0
Dst_maxx=10.0
Dst_maxy=10.0
! setup source grid
srcGrid=ESMF_GridCreateNoPeriDim(minIndex=(/1,1/),maxIndex=(/src_nx,src_ny/),regDecomp=(/petCount,1/), &
coordSys=ESMF_COORDSYS_CART, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! setup dest. grid
dstGrid=ESMF_GridCreateNoPeriDim(minIndex=(/1,1/),maxIndex=(/dst_nx,dst_ny/),regDecomp=(/1,petCount/), &
indexflag=ESMF_INDEX_GLOBAL, &
coordSys=ESMF_COORDSYS_CART, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source/destination fields
call ESMF_ArraySpecSet(arrayspec, 2, ESMF_TYPEKIND_R8, rc=rc)
srcField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcFracField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcArea = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
errorField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstFracField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
xdstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstArea = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Allocate coordinates
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Add Masks
call ESMF_GridAddItem(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddItem(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get number of local DEs
call ESMF_GridGet(srcGrid, localDECount=localDECount, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get arrays
! dstArray
call ESMF_FieldGet(dstField, array=dstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! srcArray
call ESMF_FieldGet(srcField, array=srcArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! xdstArray
call ESMF_FieldGet(xdstField, array=xdstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! errorArray
call ESMF_FieldGet(errorField, array=errorArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(srcArea, array=srcAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(dstArea, array=dstAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Source Grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Construct 3D Grid A
! (Get memory and set coords for src)
do lDE=0,localDECount-1
!! SET CORNER STAGGER COORDS
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
farrayPtr=fptrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=fptrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set source coordinates
fptrXC(i1,i2) = ((Src_maxx-Src_minx)*REAL(i1-1)/REAL(Src_nx-1))+Src_minx
fptrYC(i1,i2) = ((Src_maxy-Src_miny)*REAL(i2-1)/REAL(Src_ny-1))+Src_miny
enddo
enddo
!! SET CENTER STAGGER COORDS, FUNC, ETC.
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
farrayPtr=fptrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=fptrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src pointer
call ESMF_FieldGet(srcField, lDE, fptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetItem(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=srcMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
!!! compute corner coordinates surrounding center
cnr_x = ((Src_maxx-Src_minx)*REAL(i1-1)/REAL(Src_nx-1))+Src_minx
cnr_xp1 = ((Src_maxx-Src_minx)*REAL(i1-1+1)/REAL(Src_nx-1))+Src_minx
cnr_y = ((Src_maxy-Src_miny)*REAL(i2-1)/REAL(Src_ny-1))+Src_miny
cnr_yp1 = ((Src_maxy-Src_miny)*REAL(i2-1+1)/REAL(Src_ny-1))+Src_miny
! Calc Center coordinates as average of corner coords
x = (cnr_x+cnr_xp1)/2.0
y = (cnr_y+cnr_yp1)/2.0
! Set source value
fptr(i1,i2)=x+y+20.0
! Set Center coordinates
fptrXC(i1,i2) = x
fptrYC(i1,i2) = y
! Set Mask
if ((x > 4.0) .and. (x < 6.0)) then
srcMask(i1,i2)=1
else
srcMask(i1,i2)=0
endif
enddo
enddo
enddo ! lDE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Destination grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Get memory and set coords for dst
do lDE=0,localDECount-1
!! get coords
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=fptrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=fptrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
fptrXC(i1,i2) = ((Dst_maxx-Dst_minx)*REAL(i1-1)/REAL(Dst_nx-1))+Dst_minx
fptrYC(i1,i2) = ((Dst_maxy-Dst_miny)*REAL(i2-1)/REAL(Dst_ny-1))+Dst_miny
enddo
enddo
!! DO CENTER STAGGER STUFF
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=fptrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=fptrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=dstMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst pointer
call ESMF_FieldGet(dstField, lDE, fptr, computationalLBound=fclbnd, &
computationalUBound=fcubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact pointer
call ESMF_FieldGet(xdstField, lDE, xfptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
!!! compute corner coordinates surrounding center
cnr_x = ((Dst_maxx-Dst_minx)*REAL(i1-1)/REAL(Dst_nx-1))+Dst_minx
cnr_xp1 = ((Dst_maxx-Dst_minx)*REAL(i1-1+1)/REAL(Dst_nx-1))+Dst_minx
cnr_y = ((Dst_maxy-Dst_miny)*REAL(i2-1)/REAL(Dst_ny-1))+Dst_miny
cnr_yp1 = ((Dst_maxy-Dst_miny)*REAL(i2-1+1)/REAL(Dst_ny-1))+Dst_miny
! Calc Center coordinates as average of corner coords
x = (cnr_x+cnr_xp1)/2.0
y = (cnr_y+cnr_yp1)/2.0
! Set Center coordinates
fptrXC(i1,i2) = x
fptrYC(i1,i2) = y
! Init dest
fptr(i1,i2)=0.0
! Init exact destination value
xfptr(i1,i2)=x+y+20.0
! Set mask
if ((y > 4.0) .and. (y < 6.0)) then
dstMask(i1,i2)=1
else
dstMask(i1,i2)=0
endif
enddo
enddo
enddo ! lDE
! Regrid store
call ESMF_FieldRegridStore(srcField, srcMaskValues=(/1/), &
dstField=dstField, dstMaskValues=(/1/), &
routeHandle=routeHandle, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
dstmass = 0.
! Check if the values are close
do lDE=0,localDECount-1
! get dst Field
call ESMF_FieldGet(dstField, lDE, fptr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, lDE, xfptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get destination mask field
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=dstMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get error Field
call ESMF_FieldGet(errorField, lDE, errorfptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstArea, lDE, dstAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, lDE, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! skip if masked
if (dstMask(i1,i2) .eq. 1) cycle
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1,i2)*fptr(i1,i2)
! Instead do this
dstmass = dstmass + dstAreaptr(i1,i2)*fptr(i1,i2)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1,i2) .lt. 0.999) cycle
if (xfptr(i1,i2) .ne. 0.0) then
errorfptr(i1,i2)=ABS(fptr(i1,i2) - xfptr(i1,i2))/ABS(xfptr(i1,i2))
error = error + errorfptr(i1,i2)
if (errorfptr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfptr(i1,i2)
endif
if (errorfptr(i1,i2) < minerror(1)) then
minerror(1) = errorfptr(i1,i2)
endif
else
errorfptr(i1,i2)=ABS(fptr(i1,i2) - xfptr(i1,i2))
error = error + errorfptr(i1,i2)
if (errorfptr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfptr(i1,i2)
endif
if (errorfptr(i1,i2) < minerror(1)) then
minerror(1) = errorfptr(i1,i2)
endif
endif
enddo
enddo
enddo ! lDE
srcmass(1) = 0.
do lDE=0,localDECount-1
! get src pointer
call ESMF_FieldGet(srcField, lDE, fptr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcArea, lDE, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, lDE, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
srcmass(1) = srcmass(1) + srcFracptr(i1,i2)*srcAreaptr(i1,i2)*fptr(i1,i2)
enddo
enddo
enddo ! lDE
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Cartesian grid with masks ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
#if 0
spherical_grid = 1
call ESMF_MeshIO(vm, srcGrid, ESMF_STAGGERLOC_CENTER, &
"srcmesh", srcArray, srcAreaArray, rc=localrc, &
spherical=spherical_grid)
call ESMF_MeshIO(vm, dstGrid, ESMF_STAGGERLOC_CENTER, &
"dstmesh", dstArray, xdstArray, errorArray, dstAreaarray, rc=localrc, &
spherical=spherical_grid)
#endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(errorField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the grids
call ESMF_GridDestroy(srcGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridDestroy(dstGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
end subroutine test_cartcsrvregridwmasks
subroutine test_3Dcartcsrvregridwmasks(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Grid) :: srcGrid
type(ESMF_Grid) :: dstGrid
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: dstFracField
type(ESMF_Field) :: srcFracField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: errorField
type(ESMF_Field) :: srcArea, dstArea
type(ESMF_Array) :: dstArray, dstFracArray
type(ESMF_Array) :: xdstArray
type(ESMF_Array) :: errorArray
type(ESMF_Array) :: srcArray
type(ESMF_Array) :: srcAreaArray, dstAreaArray
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
integer(ESMF_KIND_I4), pointer :: srcMask(:,:,:), dstMask(:,:,:)
real(ESMF_KIND_R8), pointer :: fptrXC(:,:,:)
real(ESMF_KIND_R8), pointer :: fptrYC(:,:,:)
real(ESMF_KIND_R8), pointer :: fptrZC(:,:,:)
real(ESMF_KIND_R8), pointer :: fptr(:,:,:),xfptr(:,:,:),errorfptr(:,:,:),iwtsptr(:,:,:)
real(ESMF_KIND_R8), pointer :: srcAreaptr(:,:,:), dstAreaptr(:,:,:)
real(ESMF_KIND_R8), pointer :: srcFracptr(:,:,:), dstFracptr(:,:,:)
integer :: petMap2D(2,2,1)
integer :: clbnd(3),cubnd(3)
integer :: fclbnd(3),fcubnd(3)
integer :: i1,i2,i3
integer :: lDE, srcLocalDECount, dstLocalDECount, i
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
integer :: Src_nx, Src_ny, Src_nz
integer :: Dst_nx, Dst_ny, Dst_nz
real(ESMF_KIND_R8) :: x,y,z
real(ESMF_KIND_R8) :: cnr_x,cnr_xp1
real(ESMF_KIND_R8) :: cnr_y,cnr_yp1
real(ESMF_KIND_R8) :: cnr_z,cnr_zp1
real(ESMF_KIND_R8) :: Src_dx, Src_dy, Src_dz
real(ESMF_KIND_R8) :: Dst_dx, Dst_dy, Dst_dz
real(ESMF_KIND_R8) :: Src_minx, Src_miny, Src_minz
real(ESMF_KIND_R8) :: Src_maxx, Src_maxy, Src_maxz
real(ESMF_KIND_R8) :: Dst_minx, Dst_miny, Dst_minz
real(ESMF_KIND_R8) :: Dst_maxx, Dst_maxy, Dst_maxz
real(ESMF_KIND_R8) :: ctheta, stheta
real(ESMF_KIND_R8) :: xtmp, ytmp, ztmp
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
integer :: spherical_grid,dim
real(ESMF_KIND_R8) :: mincoord(3), maxcoord(3)
integer, pointer :: larrayList(:)
integer :: localPet, petCount
! result code
integer :: finalrc
! init success flag
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Establish the resolution of the grids
Src_nx = 30
Src_ny = 30
Src_nz = 30
Src_minx=0.0
Src_miny=0.0
Src_minz=0.0
Src_maxx=10.0
Src_maxy=10.0
Src_maxz=10.0
Dst_nx = 20
Dst_ny = 20
Dst_nz = 20
Dst_minx=0.0
Dst_miny=0.0
Dst_minz=0.0
Dst_maxx=10.0
Dst_maxy=10.0
Dst_maxz=10.0
! setup source grid
srcGrid=ESMF_GridCreateNoPeriDim(minIndex=(/1,1,1/),maxIndex=(/src_nx,src_ny,src_nz/),regDecomp=(/petCount,1,1/), &
coordSys=ESMF_COORDSYS_CART, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! setup dest. grid
dstGrid=ESMF_GridCreateNoPeriDim(minIndex=(/1,1,1/),maxIndex=(/dst_nx,dst_ny,dst_nz/),regDecomp=(/1,petCount,1/), &
coordSys=ESMF_COORDSYS_CART, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source/destination fields
call ESMF_ArraySpecSet(arrayspec, 3, ESMF_TYPEKIND_R8, rc=rc)
srcField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcFracField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcArea = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
errorField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstFracField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
xdstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstArea = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Allocate coordinates
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CORNER_VFACE, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CORNER_VFACE, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Add Masks
call ESMF_GridAddItem(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddItem(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get number of local DEs in source grid
call ESMF_GridGet(srcGrid, localDECount=srcLocalDECount, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get number of local DEs in dest. grid
call ESMF_GridGet(dstGrid, localDECount=dstLocalDECount, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get arrays
! dstArray
call ESMF_FieldGet(dstField, array=dstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! srcArray
call ESMF_FieldGet(srcField, array=srcArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! xdstArray
call ESMF_FieldGet(xdstField, array=xdstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! errorArray
call ESMF_FieldGet(errorField, array=errorArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Frac array
call ESMF_FieldGet(dstFracField, array=dstFracArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(srcArea, array=srcAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(dstArea, array=dstAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Source Grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Construct 3D Grid A
! (Get memory and set coords for src)
do lDE=0,srclocalDECount-1
!! SET CORNER STAGGER COORDS
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER_VFACE, coordDim=1, &
farrayPtr=fptrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER_VFACE, coordDim=2, &
farrayPtr=fptrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER_VFACE, coordDim=3, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=fptrZC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
do i3=clbnd(3),cubnd(3)
! Set source coordinates
fptrXC(i1,i2,i3) = ((Src_maxx-Src_minx)*REAL(i1-1)/REAL(Src_nx))+Src_minx
fptrYC(i1,i2,i3) = ((Src_maxy-Src_miny)*REAL(i2-1)/REAL(Src_ny))+Src_miny
fptrZC(i1,i2,i3) = ((Src_maxz-Src_minz)*REAL(i3-1)/REAL(Src_nz))+Src_minz
enddo
enddo
enddo
!! SET CENTER STAGGER COORDS, FUNC, ETC.
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
farrayPtr=fptrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
farrayPtr=fptrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=3, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=fptrZC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src pointer
call ESMF_FieldGet(srcField, lDE, fptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetItem(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=srcMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
do i3=clbnd(3),cubnd(3)
!!! compute corner coordinates surrounding center
cnr_x = ((Src_maxx-Src_minx)*REAL(i1-1)/REAL(Src_nx))+Src_minx
cnr_xp1 = ((Src_maxx-Src_minx)*REAL(i1-1+1)/REAL(Src_nx))+Src_minx
cnr_y = ((Src_maxy-Src_miny)*REAL(i2-1)/REAL(Src_ny))+Src_miny
cnr_yp1 = ((Src_maxy-Src_miny)*REAL(i2-1+1)/REAL(Src_ny))+Src_miny
cnr_z = ((Src_maxz-Src_minz)*REAL(i3-1)/REAL(Src_nz))+Src_minz
cnr_zp1 = ((Src_maxz-Src_minz)*REAL(i3-1+1)/REAL(Src_nz))+Src_minz
! Calc Center coordinates as average of corner coords
x = (cnr_x+cnr_xp1)/2.0
y = (cnr_y+cnr_yp1)/2.0
z = (cnr_z+cnr_zp1)/2.0
! Set source value
fptr(i1,i2,i3)=x+y+z+20.0
! fptr(i1,i2,i3)=1.0
! Set Center coordinates
fptrXC(i1,i2,i3) = x
fptrYC(i1,i2,i3) = y
fptrZC(i1,i2,i3) = z
! Set Mask
if ((x > 4.0) .and. (x < 6.0)) then
srcMask(i1,i2,i3)=1
else
srcMask(i1,i2,i3)=0
endif
enddo
enddo
enddo
enddo ! lDE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Destination grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Get memory and set coords for dst
do lDE=0,dstlocalDECount-1
!! get coords
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER_VFACE, coordDim=1, &
farrayPtr=fptrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER_VFACE, coordDim=2, &
farrayPtr=fptrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER_VFACE, coordDim=3, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=fptrZC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
mincoord=10000
maxcoord=-10000
!! set coords
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
do i3=clbnd(3),cubnd(3)
fptrXC(i1,i2,i3) = ((Dst_maxx-Dst_minx)*REAL(i1-1)/REAL(Dst_nx))+Dst_minx
fptrYC(i1,i2,i3) = ((Dst_maxy-Dst_miny)*REAL(i2-1)/REAL(Dst_ny))+Dst_miny
fptrZC(i1,i2,i3) = ((Dst_maxz-Dst_minz)*REAL(i3-1)/REAL(Dst_nz))+Dst_minz
enddo
enddo
enddo
!! DO CENTER STAGGER STUFF
!! get coord 1
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
farrayPtr=fptrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
farrayPtr=fptrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=3, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=fptrZC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=dstMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst pointer
call ESMF_FieldGet(dstField, lDE, fptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact pointer
call ESMF_FieldGet(xdstField, lDE, xfptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
do i3=clbnd(3),cubnd(3)
!!! compute corner coordinates surrounding center
cnr_x = ((Dst_maxx-Dst_minx)*REAL(i1-1)/REAL(Dst_nx))+Dst_minx
cnr_xp1 = ((Dst_maxx-Dst_minx)*REAL(i1-1+1)/REAL(Dst_nx))+Dst_minx
cnr_y = ((Dst_maxy-Dst_miny)*REAL(i2-1)/REAL(Dst_ny))+Dst_miny
cnr_yp1 = ((Dst_maxy-Dst_miny)*REAL(i2-1+1)/REAL(Dst_ny))+Dst_miny
cnr_z = ((Dst_maxz-Dst_minz)*REAL(i3-1)/REAL(Dst_nz))+Dst_minz
cnr_zp1 = ((Dst_maxz-Dst_minz)*REAL(i3-1+1)/REAL(Dst_nz))+Dst_minz
! Calc Center coordinates as average of corner coords
x = (cnr_x+cnr_xp1)/2.0
y = (cnr_y+cnr_yp1)/2.0
z = (cnr_z+cnr_zp1)/2.0
! Set Center coordinates
fptrXC(i1,i2,i3) = x
fptrYC(i1,i2,i3) = y
fptrZC(i1,i2,i3) = z
! Init dest
fptr(i1,i2,i3)=0.0
! Init exact destination value
xfptr(i1,i2,i3)=x+y+z+20.0
! xfptr(i1,i2,i3)=1.0
! Set mask
if ((y > 4.0) .and. (y < 6.0)) then
dstMask(i1,i2,i3)=1
else
dstMask(i1,i2,i3)=0
endif
enddo
enddo
enddo
enddo ! lDE
! Regrid store
call ESMF_FieldRegridStore(srcField, srcMaskValues=(/1/), &
dstField=dstField, dstMaskValues=(/1/), &
routeHandle=routeHandle, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
dstmass = 0.
do lDE=0,dstLocalDECount-1
! get dst Field
call ESMF_FieldGet(dstField, lDE, fptr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, lDE, xfptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get destination mask field
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=dstMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get error Field
call ESMF_FieldGet(errorField, lDE, errorfptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstArea, lDE, dstAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, lDE, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
do i3=clbnd(3),cubnd(3)
! skip if masked
if (dstMask(i1,i2,i3) .eq. 1) cycle
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1,i2)*fptr(i1,i2)
! Instead do this
dstmass = dstmass + dstAreaptr(i1,i2,i3)*fptr(i1,i2,i3)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1,i2,i3) .lt. 0.999) cycle
if (xfptr(i1,i2,i3) .ne. 0.0) then
errorfptr(i1,i2,i3)=ABS(fptr(i1,i2,i3) - xfptr(i1,i2,i3))/ABS(xfptr(i1,i2,i3))
error = error + errorfptr(i1,i2,i3)
if (errorfptr(i1,i2,i3) > maxerror(1)) then
maxerror(1) = errorfptr(i1,i2,i3)
endif
if (errorfptr(i1,i2,i3) < minerror(1)) then
minerror(1) = errorfptr(i1,i2,i3)
endif
else
errorfptr(i1,i2,i3)=ABS(fptr(i1,i2,i3) - xfptr(i1,i2,i3))
error = error + errorfptr(i1,i2,i3)
if (errorfptr(i1,i2,i3) > maxerror(1)) then
maxerror(1) = errorfptr(i1,i2,i3)
endif
if (errorfptr(i1,i2,i3) < minerror(1)) then
minerror(1) = errorfptr(i1,i2,i3)
endif
endif
enddo
enddo
enddo
enddo ! lDE
srcmass(1) = 0.
do lDE=0,srcLocalDECount-1
! get src pointer
call ESMF_FieldGet(srcField, lDE, fptr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcArea, lDE, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, lDE, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
do i3=clbnd(3),cubnd(3)
srcmass(1) = srcmass(1) + srcFracptr(i1,i2,i3)*srcAreaptr(i1,i2,i3)*fptr(i1,i2,i3)
enddo
enddo
enddo
enddo ! lDE
#if 0
call ESMF_GridWriteVTK(srcGrid,staggerloc=ESMF_STAGGERLOC_CORNER_VFACE, &
filename="srcGridCnr", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridWriteVTK(srcGrid,staggerloc=ESMF_STAGGERLOC_CENTER, &
filename="srcGrid", array1=srcArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridWriteVTK(dstGrid,staggerloc=ESMF_STAGGERLOC_CORNER_VFACE, &
filename="dstGridCnr", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridWriteVTK(dstGrid,staggerloc=ESMF_STAGGERLOC_CENTER, &
filename="dstGrid",&
array1=dstArray, array2=xdstArray, array3=errorArray, array4=dstFracArray, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
#endif
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== 3D Cartesian grid with masks ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
#if 0
spherical_grid = 1
call ESMF_MeshIO(vm, srcGrid, ESMF_STAGGERLOC_CENTER, &
"srcmesh", srcArray, srcAreaArray, rc=localrc, &
spherical=spherical_grid)
call ESMF_MeshIO(vm, dstGrid, ESMF_STAGGERLOC_CENTER, &
"dstmesh", dstArray, xdstArray, errorArray, dstAreaarray, rc=localrc, &
spherical=spherical_grid)
#endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(errorField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the grids
call ESMF_GridDestroy(srcGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridDestroy(dstGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
end subroutine test_3Dcartcsrvregridwmasks
subroutine test_RegridCsrv3DCartMesh(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Mesh) :: srcMesh
type(ESMF_Mesh) :: dstMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: srcAreaField, dstAreaField
type(ESMF_Field) :: srcFracField, dstFracField
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: srcFarrayPtr(:), dstFarrayPtr(:), xdstFarrayPtr(:)
real(ESMF_KIND_R8), pointer :: srcAreaPtr(:), dstAreaPtr(:)
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
integer :: i1,i2,i3
real(ESMF_KIND_R8) :: x,y,z
integer :: localPet, petCount
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
real(ESMF_KIND_R8) :: errorTot, errorTotG
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes, numElems
integer :: iconn,inode
! result code
integer :: finalrc
! Init to success
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
! Setup source mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=18
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9, &
10,11,12,13,14,15,16,17,18/)
! Allocate and fill node coordinate array.
! Since this is a 3D Mesh the size is 3x the
! number of nodes.
allocate(nodeCoords(3*numNodes))
nodeCoords=(/0.0,0.0,0.0, & ! node id 1
1.0,0.0,0.0, & ! node id 2
2.0,0.0,0.0, & ! node id 3
0.0,1.0,0.0, & ! node id 4
1.0,1.0,0.0, & ! node id 5
2.0,1.0,0.0, & ! node id 6
0.0,2.0,0.0, & ! node id 7
1.0,2.0,0.0, & ! node id 8
2.0,2.0,0.0, & ! node id 9
0.0,0.0,1.0, & ! node id 10
1.0,0.0,1.0, & ! node id 11
2.0,0.0,1.0, & ! node id 12
0.0,1.0,1.0, & ! node id 13
1.0,1.0,1.0, & ! node id 14
2.0,1.0,1.0, & ! node id 15
0.0,2.0,1.0, & ! node id 16
1.0,2.0,1.0, & ! node id 17
2.0,2.0,1.0 /) ! node id 18
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numElems=4
! Allocate and fill the element id array.
allocate(elemIds(numElems))
elemIds=(/1,2,3,4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElems))
elemTypes=ESMF_MESHELEMTYPE_HEX
! Allocate and fill the element mask array
allocate(elemMask(numElems))
elemMask=(/0,0,0,1/)
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(8*numElems))
elemConn=(/1,2,5,4,10,11,14,13, & ! elem id 1
2,3,6,5,11,12,15,14, & ! elem id 2
4,5,8,7,13,14,17,16, & ! elem id 3
5,6,9,8,14,15,18,17/) ! elem id 4
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=8
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5,10,11,13,14/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(3*numNodes))
nodeCoords=(/0.0,0.0,0.0, & ! node id 1
1.0,0.0,0.0, & ! node id 2
0.0,1.0,0.0, & ! node id 4
1.0,1.0,0.0, & ! node id 5
0.0,0.0,1.0, & ! node id 10
1.0,0.0,1.0, & ! node id 11
0.0,1.0,1.0, & ! node id 13
1.0,1.0,1.0 /) ! node id 14
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0, & ! node id 5
0, & ! node id 10
0, & ! node id 11
0, & ! node id 13
0/) ! node id 14
! Set the number of each type of element, plus the total number.
numElems=1
! Allocate and fill the element id array.
allocate(elemIds(numElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_HEX/) ! elem id 1
! Allocate and fill the element mask array
allocate(elemMask(numElems))
elemMask=(/0/)
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(8*numElems))
elemConn=(/1,2,4,3,5,6,8,7/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=8
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6,11,12,14,15/)
! Allocate and fill node coordinate array.
! Since this is a 3D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(3*numNodes))
nodeCoords=(/1.0,0.0,0.0, & ! node id 2
2.0,0.0,0.0, & ! node id 3
1.0,1.0,0.0, & ! node id 5
2.0,1.0,0.0, & ! node id 6
1.0,0.0,1.0, & ! node id 11
2.0,0.0,1.0, & ! node id 12
1.0,1.0,1.0, & ! node id 14
2.0,1.0,1.0/) ! node id 15
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1, & ! node id 6
0, & ! node id 11
1, & ! node id 12
0, & ! node id 14
1/) ! node id 15
! Set the number of each type of element, plus the total number.
numElems=1
! Allocate and fill the element id array.
allocate(elemIds(numElems))
elemIds=(/2/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_HEX/) ! elem id 1
! Allocate and fill the element mask array
allocate(elemMask(numElems))
elemMask=(/0/)
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(8*numElems))
elemConn=(/1,2,4,3,5,6,8,7/) ! elem id 1
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=8
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8,13,14,16,17/)
! Allocate and fill node coordinate array.
! Since this is a 3D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(3*numNodes))
nodeCoords=(/0.0,1.0,0.0, & ! node id 4
1.0,1.0,0.0, & ! node id 5
0.0,2.0,0.0, & ! node id 7
1.0,2.0,0.0, & ! node id 8
0.0,1.0,1.0, & ! node id 13
1.0,1.0,1.0, & ! node id 14
0.0,2.0,1.0, & ! node id 16
1.0,2.0,1.0/) ! node id 17
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2, & ! node id 8
0, & ! node id 13
0, & ! node id 14
2, & ! node id 16
2/) ! node id 17
! Set the number of each type of element, plus the total number.
numElems=1
! Allocate and fill the element id array.
allocate(elemIds(numElems))
elemIds=(/3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_HEX/) ! elem id 1
! Allocate and fill the element mask array
allocate(elemMask(numElems))
elemMask=(/0/)
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(8*numElems))
elemConn=(/1,2,4,3,5,6,8,7/) ! elem id 1
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=8
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9,14,15,17,18/)
! Allocate and fill node coordinate array.
! Since this is a 3D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(3*numNodes))
nodeCoords=(/1.0,1.0,0.0, & ! node id 5
2.0,1.0,0.0, & ! node id 6
1.0,2.0,0.0, & ! node id 8
2.0,2.0,0.0, & ! node id 9
1.0,1.0,1.0, & ! node id 14
2.0,1.0,1.0, & ! node id 15
1.0,2.0,1.0, & ! node id 17
2.0,2.0,1.0/) ! node id 18
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3, & ! node id 9
0, & ! node id 14
1, & ! node id 15
2, & ! node id 17
3/) ! node id 18
! Set the number of each type of element, plus the total number.
numElems=1
! Allocate and fill the element id array.
allocate(elemIds(numElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_HEX/) ! elem id 1
! Allocate and fill the element mask array
allocate(elemMask(numElems))
elemMask=(/1/)
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(8*numElems))
elemConn=(/1,2,4,3,5,6,8,7/) ! elem id 1
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=3,spatialDim=3, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
elementMask=elemMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec for fields
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create source field
srcField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source area field
srcAreaField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Load test data into the source Field
! Should only be 1 localDE
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
z=0.0
do i3=1,8 ! 8 is the number of nodes in each element
inode=3*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
z=z+nodeCoords(inode+3)
iconn=iconn+1
enddo
x=0.125*x
y=0.125*y
z=0.125*z
! Set source function
! (Set huge value for masked values, so it can be detected)
if (elemMask(i1) .eq. 0) then
srcFarrayPtr(i1) = 20.0+x+y+z
else
srcFarrayPtr(i1) = 100000000.0
endif
enddo
! For now, Easy set interpolated function
!srcFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
deallocate(elemMask)
!!!!!!!!!!!!!!! setup destination Mesh !!!!!!!!!!!!!!!!!
! setup source Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=10
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9, &
10/)
! Allocate and fill node coordinate array.
! Since this is a 3D Mesh the size is 3x the
! number of nodes.
allocate(nodeCoords(3*numNodes))
nodeCoords=(/0.0,0.0,0.0, & ! node id 1
1.0,0.0,0.0, & ! node id 2
2.0,0.0,0.0, & ! node id 3
0.5,1.0,0.0, & ! node id 4
1.5,1.0,0.0, & ! node id 5
1.0,2.0,0.0, & ! node id 6
0.5,0.5,1.0, & ! node id 7
1.0,0.5,1.0, & ! node id 8
1.5,0.5,1.0, & ! node id 9
1.0,1.5,1.0/) ! node id 10
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numElems=4
! Allocate and fill the element id array.
allocate(elemIds(numElems))
elemIds=(/1,2,3,4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElems))
elemTypes=ESMF_MESHELEMTYPE_TETRA
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(4*numElems))
elemConn=(/1,2,7,4, & ! elem id 1
2,3,9,5, & ! elem id 2
2,5,8,4, & ! elem id 3
4,5,10,6/) ! elem id 4
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,7/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(3*numNodes))
nodeCoords=(/0.0,0.0,0.0, & ! node id 1
1.0,0.0,0.0, & ! node id 2
0.5,1.0,0.0, & ! node id 4
0.5,0.5,1.0/) ! node id 7
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 7
! Set the number of each type of element, plus the total number.
numElems=1
! Allocate and fill the element id array.
allocate(elemIds(numElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_TETRA/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,9/)
! Allocate and fill node coordinate array.
! Since this is a 3D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(3*numNodes))
nodeCoords=(/1.0,0.0,0.0, & ! node id 2
2.0,0.0,0.0, & ! node id 3
1.5,1.0,0.0, & ! node id 5
1.5,0.5,1.0/) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
2, & ! node id 5
1/) ! node id 9
! Set the number of each type of element, plus the total number.
numElems=1
! Allocate and fill the element id array.
allocate(elemIds(numElems))
elemIds=(/2/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_TETRA/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,4,5,8/)
! Allocate and fill node coordinate array.
! Since this is a 3D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(3*numNodes))
nodeCoords=(/1.0,0.0,0.0, & ! node id 2
0.5,1.0,0.0, & ! node id 4
1.5,1.0,0.0, & ! node id 5
1.0,0.5,1.0/) ! node id 8
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
0, & ! node id 4
2, & ! node id 5
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numElems=1
! Allocate and fill the element id array.
allocate(elemIds(numElems))
elemIds=(/3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_TETRA/) ! elem id 3
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numElems))
elemConn=(/1,3,4,2/) ! elem id 3
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,6,10/)
! Allocate and fill node coordinate array.
! Since this is a 3D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(3*numNodes))
nodeCoords=(/0.5,1.0,0.0, & ! node id 4
1.5,1.0,0.0, & ! node id 5
1.0,2.0,0.0, & ! node id 6
1.0,1.5,1.0/) ! node id 10
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
2, & ! node id 5
3, & ! node id 6
3/) ! node id 10
! Set the number of each type of element, plus the total number.
numElems=1
! Allocate and fill the element id array.
allocate(elemIds(numElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_TETRA/) ! elem id 4
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numElems))
elemConn=(/1,2,4,3/) ! elem id 4
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=3,spatialDim=3, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create dest. field
dstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. area field
dstAreaField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create exact dest. field
xdstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="xdest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
! Should only be 1 localDE
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
dstFarrayPtr=0.0
! Init exact destination field
! Should only be 1 localDE
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
z=0.0
do i3=1,4 ! 4 is the number of nodes in each element
inode=3*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
z=z+nodeCoords(inode+3)
iconn=iconn+1
enddo
x=0.25*x
y=0.25*y
z=0.25*z
! Set source function
xdstFarrayPtr(i1) = 20.0+x+y+z
enddo
! For now, Easy set interpolated function
!xdstFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
srcMaskValues=(/1/), &
dstField=dstField, &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
errorTot=0.0
dstmass = 0.
! get dst Field
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstAreaField, 0, dstAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, 0, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1)*fptr(i1)
! Instead do this
dstmass = dstmass + dstAreaptr(i1)*dstFarrayPtr(i1)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1) .lt. 0.999) cycle
! write(*,*) i1,"::",dstFarrayPtr(i1),xdstFarrayPtr(i1)
if (xdstFarrayPtr(i1) .ne. 0.0) then
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
else
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
endif
enddo
srcmass(1) = 0.
! get src pointer
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcAreaField, 0, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, 0, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
srcmass(1) = srcmass(1) + srcFracptr(i1)*srcAreaptr(i1)*srcFarrayPtr(i1)
enddo
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== 3D Cartesian Mesh ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the meshes
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return success if we've gotten this far
rc=ESMF_SUCCESS
end subroutine test_RegridCsrv3DCartMesh
subroutine test_csrvregridwmasksUserArea(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Grid) :: srcGrid
type(ESMF_Grid) :: dstGrid
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: dstFracField
type(ESMF_Field) :: srcFracField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: errorField
type(ESMF_Field) :: srcArea, dstArea
type(ESMF_Array) :: dstArray
type(ESMF_Array) :: xdstArray
type(ESMF_Array) :: errorArray
type(ESMF_Array) :: srcArray
type(ESMF_Array) :: srcAreaArray, dstAreaArray
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
integer(ESMF_KIND_I4), pointer :: srcMask(:,:), dstMask(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtrXC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtrYC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtr(:,:),xfarrayPtr(:,:),errorfarrayPtr(:,:),iwtsptr(:,:)
real(ESMF_KIND_R8), pointer :: srcAreaptr(:,:), dstAreaptr(:,:)
real(ESMF_KIND_R8), pointer :: srcFracptr(:,:), dstFracptr(:,:)
integer :: petMap2D(2,2,1)
integer :: clbnd(2),cubnd(2)
integer :: fclbnd(2),fcubnd(2)
integer :: i1,i2, index(2)
integer :: lDE, localDECount, i
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
integer :: Src_nx, Src_ny
integer :: Dst_nx, Dst_ny
real(ESMF_KIND_R8) :: Src_dx, Src_dy, yp1
real(ESMF_KIND_R8) :: Dst_dx, Dst_dy
real(ESMF_KIND_R8) :: ctheta, stheta
real(ESMF_KIND_R8) :: theta, d2rad, x, y, z
real(ESMF_KIND_R8) :: DEG2RAD, a, lat, lon, phi
real(ESMF_KIND_R8) :: xtmp, ytmp, ztmp
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
integer :: spherical_grid
integer, pointer :: larrayList(:)
integer :: localPet, petCount
integer :: src_num, dst_num
integer :: tmp(1), gtmp(1)
! result code
integer :: finalrc
! init success flag
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Establish the resolution of the grids
Src_nx = 180
Src_ny = 100
Src_dx = 360.0/Src_nx
Src_dy = 180.0/Src_ny
Dst_nx = 100
Dst_ny = 80
Dst_dx = 360.0/Dst_nx
Dst_dy = 180.0/Dst_ny
! degree to rad conversion
DEG2RAD = 3.141592653589793_ESMF_KIND_R8/180.0_ESMF_KIND_R8
! setup source grid
srcGrid=ESMF_GridCreate1PeriDim(minIndex=(/1,1/),maxIndex=(/src_nx,src_ny/),regDecomp=(/petCount,1/), &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! setup dest. grid
dstGrid=ESMF_GridCreate1PeriDim(minIndex=(/1,1/),maxIndex=(/dst_nx,dst_ny/),regDecomp=(/1,petCount/), &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source/destination fields
call ESMF_ArraySpecSet(arrayspec, 2, ESMF_TYPEKIND_R8, rc=rc)
srcField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcFracField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcArea = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
errorField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstFracField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
xdstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstArea = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Allocate coordinates
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Add Masks
call ESMF_GridAddItem(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddItem(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Add Area
call ESMF_GridAddItem(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_AREA, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddItem(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_AREA, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get number of local DEs
call ESMF_GridGet(srcGrid, localDECount=localDECount, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get arrays
! dstArray
call ESMF_FieldGet(dstField, array=dstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! srcArray
call ESMF_FieldGet(srcField, array=srcArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! xdstArray
call ESMF_FieldGet(xdstField, array=xdstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! errorArray
call ESMF_FieldGet(errorField, array=errorArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(srcArea, array=srcAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(dstArea, array=dstAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Source Grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! (Get memory and set coords for src)
src_num=0
do lDE=0,localDECount-1
!! get coord 1
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Src_dx
farrayPtrYC(i1,i2) = REAL(i2-1)*Src_dy - 90.0
enddo
enddo
!! DO CENTER STAGGER STUFF
!! get coord 1
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src pointer
call ESMF_FieldGet(srcField, lDE, farrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetItem(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=srcMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
y= REAL(i2-1)*Src_dy - 90.0
yp1= REAL(i2-1+1)*Src_dy - 90.0
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Src_dx + 0.5*Src_dx
farrayPtrYC(i1,i2) = (y+yp1)/2.0
! set src data
lon = farrayPtrXC(i1,i2)
lat = farrayPtrYC(i1,i2)
! Set the source to be a function of the x,y,z coordinate
theta = DEG2RAD*(lon)
phi = DEG2RAD*(90.-lat)
! set src data
! farrayPtr(i1,i2) = 1.
farrayPtr(i1,i2) = 2. + cos(theta)**2.*cos(2.*phi)
#if 1
if ((lat>-45) .and. (lat<45)) then
srcMask(i1,i2)=1
else
srcMask(i1,i2)=0
endif
#else
srcMask(i1,i2)=0
#endif
! Set user area
src_num=src_num+1
enddo
enddo
enddo ! lDE
! Sum number of src elements
tmp(1)=src_num
call ESMF_VMAllReduce(vm, tmp, gtmp, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
src_num=gtmp(1)
! Set src areas
do lDE=0,localDECount-1
!! Get area pointer
call ESMF_GridGetItem(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_AREA, farrayPtr=srcAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! Set area, so total area is 1.0
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set user area
srcAreaPtr(i1,i2)=1.0/REAL(src_num)
enddo
enddo
enddo ! lDE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Destination grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Get memory and set coords for dst
dst_num=0
do lDE=0,localDECount-1
!! get coords
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set dest coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Dst_dx
farrayPtrYC(i1,i2) = REAL(i2-1)*Dst_dy - 90.0
enddo
enddo
!! DO CENTER STAGGER STUFF
!! get coord 1
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=dstMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst pointer
call ESMF_FieldGet(dstField, lDE, farrayPtr, computationalLBound=fclbnd, &
computationalUBound=fcubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact pointer
call ESMF_FieldGet(xdstField, lDE, xfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
y= REAL(i2-1)*Dst_dy - 90.0
yp1= REAL(i2-1+1)*Dst_dy - 90.0
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Dst_dx + 0.5*Dst_dx
farrayPtrYC(i1,i2) = (y+yp1)/2.0
! init dst data
farrayPtr(i1,i2) = 0.0
! init exact answer
lon = farrayPtrXC(i1,i2)
lat = farrayPtrYC(i1,i2)
! Set the source to be a function of the x,y,z coordinate
theta = DEG2RAD*(lon)
phi = DEG2RAD*(90.-lat)
! set exact dst data
xfarrayPtr(i1,i2) = 2. + cos(theta)**2.*cos(2.*phi)
! xfarrayPtr(i1,i2) = 1.0
#if 1
if ((lon>-45) .and. (lon<45)) then
dstMask(i1,i2)=1
else
dstMask(i1,i2)=0
endif
#else
dstMask(i1,i2)=0
#endif
dst_num=dst_num+1
enddo
enddo
enddo ! lDE
! Sum number of dst elements
tmp(1)=dst_num
call ESMF_VMAllReduce(vm, tmp, gtmp, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dst_num=gtmp(1)
! Set dst areas
do lDE=0,localDECount-1
!! Get dst area
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_AREA, farrayPtr=dstAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! Set dst area so total is 1.0
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
dstAreaPtr(i1,i2)=1.0/REAL(dst_num)
enddo
enddo
enddo ! lDE
! Regrid store
call ESMF_FieldRegridStore(srcField, srcMaskValues=(/1/), &
dstField=dstField, dstMaskValues=(/1/), &
routeHandle=routeHandle, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
dstmass = 0.
do lDE=0,localDECount-1
! get dst Field
call ESMF_FieldGet(dstField, lDE, farrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, lDE, xfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get destination mask field
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=dstMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get error Field
call ESMF_FieldGet(errorField, lDE, errorfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstArea, lDE, dstAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, lDE, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! skip if masked
if (dstMask(i1,i2) .eq. 1) cycle
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1,i2)*farrayPtr(i1,i2)
! Instead do this
dstmass = dstmass + dstAreaptr(i1,i2)*farrayPtr(i1,i2)
! If this destination cell isn't covered by a sig. amount of source, then don't compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1,i2) .lt. 0.999) cycle
if (xfarrayPtr(i1,i2) .ne. 0.0) then
errorfarrayPtr(i1,i2)=ABS((farrayPtr(i1,i2)/dstFracPtr(i1,i2)) &
- xfarrayPtr(i1,i2))/ABS(xfarrayPtr(i1,i2))
error = error + errorfarrayPtr(i1,i2)
if (errorfarrayPtr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfarrayPtr(i1,i2)
endif
if (errorfarrayPtr(i1,i2) < minerror(1)) then
minerror(1) = errorfarrayPtr(i1,i2)
endif
else
errorfarrayPtr(i1,i2)=ABS((farrayPtr(i1,i2)/dstFracPtr(i1,i2)) - xfarrayPtr(i1,i2))
error = error + errorfarrayPtr(i1,i2)
if (errorfarrayPtr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfarrayPtr(i1,i2)
endif
if (errorfarrayPtr(i1,i2) < minerror(1)) then
minerror(1) = errorfarrayPtr(i1,i2)
endif
endif
enddo
enddo
enddo ! lDE
srcmass(1) = 0.
do lDE=0,localDECount-1
! get src pointer
call ESMF_FieldGet(srcField, lDE, farrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcArea, lDE, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, lDE, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
srcmass(1) = srcmass(1) + srcFracptr(i1,i2)*srcAreaptr(i1,i2)*farrayPtr(i1,i2)
enddo
enddo
enddo ! lDE
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Spherical grids with masks and user area ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
#if 0
spherical_grid = 1
call ESMF_MeshIO(vm, srcGrid, ESMF_STAGGERLOC_CENTER, &
"srcmesh", srcArray, srcAreaArray, rc=localrc, &
spherical=spherical_grid)
call ESMF_MeshIO(vm, dstGrid, ESMF_STAGGERLOC_CENTER, &
"dstmesh", dstArray, xdstArray, errorArray, dstAreaarray, rc=localrc, &
spherical=spherical_grid)
#endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(errorField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the grids
call ESMF_GridDestroy(srcGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridDestroy(dstGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
end subroutine test_csrvregridwmasksUserArea
subroutine test_ignoreDegenerate(rc)
integer, intent(out) :: rc
logical :: correct
integer :: localrc
type(ESMF_Mesh) :: dstMesh
type(ESMF_Mesh) :: srcMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Array) :: dstArray
type(ESMF_Array) :: lonArrayA
type(ESMF_Array) :: srcArrayA
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: farrayPtrXC(:,:), farrayPtr1D(:)
real(ESMF_KIND_R8), pointer :: farrayPtrYC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtr(:,:),farrayPtr2(:,:)
integer :: clbnd(2),cubnd(2)
integer :: fclbnd(2),fcubnd(2)
integer :: i1,i2,i3, index(2)
integer :: lDE, localDECount
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
real(ESMF_KIND_R8) :: dx,dy
real(ESMF_KIND_R8) :: x,y
integer :: spherical_grid
integer, pointer :: larrayList(:)
integer :: localPet, petCount
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:)
integer :: numNodes, numElems
integer :: numQuadElems,numTriElems, numTotElems
! result code
integer :: finalrc
! init success flag
correct=.true.
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
! Setup Src Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 1
1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
0.0, 1.0, & ! node id 4
1.0, 1.0, & ! node id 5
2.0, 1.0, & ! node id 6
0.0, 2.0, & ! node id 7
1.0, 1.0, & ! node id 8
2.0, 1.0 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numQuadElems=3
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0, 1.0, & ! node id 1
1.0, 0.0, & ! node id 2
0.0, 1.0, & ! node id 4
1.0, 1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
1.0, 1.0, & ! node id 5
2.0, 1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numQuadElems=0
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,1.0, & ! node id 4
1.0,1.0, & ! node id 5
0.0,2.0, & ! node id 7
1.0,1.0 /) ! node id 8
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.0,1.0, & ! node id 6
1.0,1.0, & ! node id 8
2.0,1.0 /) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source field
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
srcField = ESMF_FieldCreate(srcMesh, arrayspec, &
meshLoc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
! Create Dest Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
0.0,1.0, & ! node id 4
1.0,1.0, & ! node id 5
2.0,1.0, & ! node id 6
0.0,2.0, & ! node id 7
1.0,2.0, & ! node id 8
2.0,2.0 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numQuadElems=3
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
0.0,1.0, & ! node id 4
1.0,1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
1.0,1.0, & ! node id 5
2.0,1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numQuadElems=0
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,1.0, & ! node id 4
1.0,1.0, & ! node id 5
0.0,2.0, & ! node id 7
1.0,2.0 /) ! node id 8
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.0,1.0, & ! node id 6
1.0,2.0, & ! node id 8
2.0,2.0 /) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest field
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
dstField = ESMF_FieldCreate(dstMesh, arrayspec, &
meshLoc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
dstField=dstField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
ignoreDegenerate=.true., &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
! Uncomment these calls to see some actual regrid results
#if 0
spherical_grid = 0
call ESMF_MeshIO(vm, dstMesh, ESMF_STAGGERLOC_EDGE1, &
"srcmesh", srcArrayA, rc=localrc, &
spherical=spherical_grid)
call ESMF_MeshIO(vm, srcGrid, ESMF_STAGGERLOC_CENTER, &
"dstmesh", dstArray, rc=localrc, &
spherical=spherical_grid)
#endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the grids
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flag
if (correct) then
rc=ESMF_SUCCESS
else
rc=ESMF_FAILURE
endif
end subroutine test_ignoreDegenerate
subroutine test_RegridCsrvCartPHMesh(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Mesh) :: srcMesh
type(ESMF_Mesh) :: dstMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: srcAreaField, dstAreaField
type(ESMF_Field) :: srcFracField, dstFracField
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: srcFarrayPtr(:), dstFarrayPtr(:), xdstFarrayPtr(:)
real(ESMF_KIND_R8), pointer :: srcAreaPtr(:), dstAreaPtr(:)
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
integer :: i1,i2,i3
real(ESMF_KIND_R8) :: x,y,z
integer :: localPet, petCount
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
real(ESMF_KIND_R8) :: errorTot, errorTotG
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes
integer :: iconn,inode
integer :: numQuadElems,numTriElems
integer :: numPentElems,numHexElems,numTotElems
integer :: numElemConn
! result code
integer :: finalrc
! Init to success
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
! Setup source mesh
! Src Mesh
!
! 2.5 8 10 --------11
! / \ / |
! 2.1 7 9 12
! | | 5 /
! | 4 | /
! | | /
! 1.0 4 ------- 5 ------- 6
! | | \ 3 |
! | 1 | \ |
! | | 2 \ |
! -0.1 1 ------- 2 ------- 3
!
! -0.1 1.0 2.1 2.5
!
! Node Id labels at corners
! Element Id labels in centers
! Setup Src Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=12
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9,10,11,12/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1,-0.1, & ! node id 1
1.0,-0.1, & ! node id 2
2.1,-0.1, & ! node id 3
-0.1, 1.0, & ! node id 4
1.0, 1.0, & ! node id 5
2.1, 1.0, & ! node id 6
-0.1, 2.1, & ! node id 7
0.5, 2.5, & ! node id 8
1.0, 2.1, & ! node id 9
1.5, 2.5, & ! node id 10
2.5, 2.5, & ! node id 11
2.5, 2.1/) ! node id 12
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus tot and num conn.
numQuadElems=1
numTriElems=2
numPentElems=1
numHexElems=1
numTotElems=numTriElems+numQuadElems+numPentElems+numHexElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+6*numHexElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0,1,0,0,0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
5, & ! elem id 4
6/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,9,8,7, & ! elem id 4
5,6,12,11,10,9/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1, -0.1, & ! node id 1
1.0, -0.1, & ! node id 2
-0.1, 1.0, & ! node id 4
1.0, 1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus tot and num conn.
numQuadElems=1
numTriElems=0
numPentElems=0
numHexElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numHexElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+6*numHexElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,-0.1, & ! node id 2
2.1,-0.1, & ! node id 3
1.0, 1.0, & ! node id 5
2.1, 1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=2
numPentElems=0
numHexElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numHexElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+6*numHexElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/1,0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=5
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1,1.0, & ! node id 4
1.0,1.0, & ! node id 5
-0.1,2.1, & ! node id 7
0.5,2.5, & ! node id 8
1.0,2.1 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2, & ! node id 8
2/) ! node id 9
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=0
numPentElems=1
numHexElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numHexElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+6*numHexElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/5/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=6
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,9,10,11,12/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.1,1.0, & ! node id 6
1.0,2.1, & ! node id 9
1.5,2.5, & ! node id 10
2.5,2.5, & ! node id 11
2.5,2.1 /) ! node id 12
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 9
3, & ! node id 10
3, & ! node id 11
3/) ! node id 12
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=0
numPentElems=0
numHexElems=1
numTotElems=numTriElems+numQuadElems+numPentElems+numHexElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+6*numHexElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/6/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,6,5,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
elementMask=elemMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec for fields
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create source field
srcField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source area field
srcAreaField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Load test data into the source Field
! Should only be 1 localDE
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
! (Set huge value for masked values, so it can be detected)
if (elemMask(i1) .eq. 0) then
srcFarrayPtr(i1) = 20.0+x+y
else
srcFarrayPtr(i1) = 100000000.0
endif
enddo
! For now, Easy set interpolated function
!srcFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
deallocate(elemMask)
!!!!!!!!!!!!!!! Setup Destination Mesh !!!!!!!!!!!!!!!!!
! Dest Mesh
!
! 2.0 7 ------- 8 ------- 9
! | | \
! 1.5 | 4 | 5 10
! | | /
! 1.0 4 ------- 5 ------- 6
! | | \ 3 |
! | 1 | \ |
! | | 2 \ |
! 0.0 1 ------- 2 ------- 3
!
! 0.0 1.0 2.0 2.25
!
! Node Id labels at corners
! Element Id labels in centers
! Create Dest Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=10
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9,10/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
0.0,1.0, & ! node id 4
1.0,1.0, & ! node id 5
2.0,1.0, & ! node id 6
0.0,2.0, & ! node id 7
1.0,2.0, & ! node id 8
2.0,2.0, & ! node id 9
2.25,1.5 /) ! node id 10
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numTriElems=2
numQuadElems=2
numPentElems=1
numTotElems=numTriElems+numQuadElems+numPentElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
5/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,10,9,8/)! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
0.0,1.0, & ! node id 4
1.0,1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=1
numPentElems=0
numTotElems=numTriElems+numQuadElems+numPentElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
1.0,1.0, & ! node id 5
2.0,1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numTriElems=2
numQuadElems=0
numPentElems=0
numTotElems=numTriElems+numQuadElems+numPentElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,1.0, & ! node id 4
1.0,1.0, & ! node id 5
0.0,2.0, & ! node id 7
1.0,2.0 /) ! node id 8
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=1
numPentElems=0
numTotElems=numTriElems+numQuadElems+numPentElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=5
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9,10/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.0,1.0, & ! node id 6
1.0,2.0, & ! node id 8
2.0,2.0, & ! node id 9
2.25,1.5 /) ! node id 10
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3, & ! node id 9
3/) ! node id 10
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=0
numPentElems=1
numTotElems=numTriElems+numQuadElems+numPentElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElemConn))
elemTypes=(/5/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create dest. field
dstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. area field
dstAreaField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create exact dest. field
xdstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="xdest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
! Should only be 1 localDE
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
dstFarrayPtr=0.0
! Init exact destination field
! Should only be 1 localDE
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
xdstFarrayPtr(i1) = 20.0+x+y
enddo
! For now, Easy set interpolated function
!xdstFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
#if 0
call ESMF_MeshWrite(srcMesh,"srcMesh")
call ESMF_MeshWrite(dstMesh,"dstMesh")
#endif
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
srcMaskValues=(/1/), &
dstField=dstField, &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
errorTot=0.0
dstmass = 0.
! get dst Field
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstAreaField, 0, dstAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, 0, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1)*fptr(i1)
! Instead do this
dstmass = dstmass + dstAreaptr(i1)*dstFarrayPtr(i1)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1) .lt. 0.999) cycle
! write(*,*) i1,"::",dstFarrayPtr(i1),xdstFarrayPtr(i1)
if (xdstFarrayPtr(i1) .ne. 0.0) then
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
else
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
endif
enddo
srcmass(1) = 0.
! get src pointer
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcAreaField, 0, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, 0, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
srcmass(1) = srcmass(1) + srcFracptr(i1)*srcAreaptr(i1)*srcFarrayPtr(i1)
enddo
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Mesh with Pentagons and Hexagons ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the meshes
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return success if we've gotten this far
rc=ESMF_SUCCESS
end subroutine test_RegridCsrvCartPHMesh
subroutine test_RegridCsrvCartMesh(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Mesh) :: srcMesh
type(ESMF_Mesh) :: dstMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: srcAreaField, dstAreaField
type(ESMF_Field) :: srcFracField, dstFracField
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: srcFarrayPtr(:), dstFarrayPtr(:), xdstFarrayPtr(:)
real(ESMF_KIND_R8), pointer :: srcAreaPtr(:), dstAreaPtr(:)
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
integer :: i1,i2,i3
real(ESMF_KIND_R8) :: x,y,z
integer :: localPet, petCount
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
real(ESMF_KIND_R8) :: errorTot, errorTotG
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes
integer :: iconn,inode
integer :: numQuadElems,numTriElems
integer :: numPentElems,numHexElems,numTotElems
integer :: numElemConn
! result code
integer :: finalrc
! Init to success
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
!!!!!!!!!!!!!!! Setup Source Mesh !!!!!!!!!!!!!!!!!
! Source Mesh
!
! 2.0 7 ------- 8 ------- 9
! | | |
! 1.5 | 4 | 5 |
! | | |
! 1.0 4 ------- 5 ------- 6
! | | \ 3 |
! | 1 | \ |
! | | 2 \ |
! 0.0 1 ------- 2 ------- 3
!
! 0.0 1.0 2.0 2.25
!
! Node Id labels at corners
! Element Id labels in centers
! Create src Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
0.0,0.8, & ! node id 4
1.0,0.8, & ! node id 5
2.0,0.8, & ! node id 6
0.0,2.0, & ! node id 7
1.0,2.0, & ! node id 8
2.0,2.0/) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numTriElems=2
numQuadElems=3
numTotElems=numTriElems+numQuadElems
numElemConn=3*numTriElems+4*numQuadElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/1,0,0,0,0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
0.0,0.8, & ! node id 4
1.0,0.8 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=1
numTotElems=numTriElems+numQuadElems
numElemConn=3*numTriElems+4*numQuadElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
1.0,0.8, & ! node id 5
2.0,0.8 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numTriElems=2
numQuadElems=0
numTotElems=numTriElems+numQuadElems
numElemConn=3*numTriElems+4*numQuadElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0,0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.8, & ! node id 4
1.0,0.8, & ! node id 5
0.0,2.0, & ! node id 7
1.0,2.0 /) ! node id 8
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=1
numTotElems=numTriElems+numQuadElems
numElemConn=3*numTriElems+4*numQuadElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.8, & ! node id 5
2.0,0.8, & ! node id 6
1.0,2.0, & ! node id 8
2.0,2.0/) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=1
numTotElems=numTriElems+numQuadElems
numElemConn=3*numTriElems+4*numQuadElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElemConn))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
elementMask=elemMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec for fields
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create source field
srcField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source area field
srcAreaField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Load test data into the source Field
! Should only be 1 localDE
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
! (Set huge value for masked values, so it can be detected)
if (elemMask(i1) .eq. 0) then
srcFarrayPtr(i1) = 20.0+x+y
else
srcFarrayPtr(i1) = 100000000.0
endif
enddo
! For now, Easy set interpolated function
!srcFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
deallocate(elemMask)
!!!!!!!!!!!!!!! Setup Destination Mesh !!!!!!!!!!!!!!!!!
! Dest Mesh
!
! 2.0 7 ------- 8 ------- 9
! | | |
! 1.5 | 4 | 5 |
! | | |
! 1.0 4 ------- 5 ------- 6
! | | \ 3 |
! | 1 | \ |
! | | 2 \ |
! 0.0 1 ------- 2 ------- 3
!
! 0.0 1.0 2.0 2.25
!
! Node Id labels at corners
! Element Id labels in centers
! Create Dest Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
0.0,1.0, & ! node id 4
1.0,1.0, & ! node id 5
2.0,1.0, & ! node id 6
0.0,2.0, & ! node id 7
1.0,2.0, & ! node id 8
2.0,2.0/) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numTriElems=2
numQuadElems=3
numTotElems=numTriElems+numQuadElems
numElemConn=3*numTriElems+4*numQuadElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
0.0,1.0, & ! node id 4
1.0,1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=1
numTotElems=numTriElems+numQuadElems
numElemConn=3*numTriElems+4*numQuadElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
1.0,1.0, & ! node id 5
2.0,1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numTriElems=2
numQuadElems=0
numTotElems=numTriElems+numQuadElems
numElemConn=3*numTriElems+4*numQuadElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,1.0, & ! node id 4
1.0,1.0, & ! node id 5
0.0,2.0, & ! node id 7
1.0,2.0 /) ! node id 8
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=1
numTotElems=numTriElems+numQuadElems
numElemConn=3*numTriElems+4*numQuadElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.0,1.0, & ! node id 6
1.0,2.0, & ! node id 8
2.0,2.0/) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=1
numTotElems=numTriElems+numQuadElems
numElemConn=3*numTriElems+4*numQuadElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElemConn))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create dest. field
dstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. area field
dstAreaField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create exact dest. field
xdstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="xdest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
! Should only be 1 localDE
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
dstFarrayPtr=0.0
! Init exact destination field
! Should only be 1 localDE
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
xdstFarrayPtr(i1) = 20.0+x+y
enddo
! For now, Easy set interpolated function
!xdstFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
#if 0
call ESMF_MeshWrite(srcMesh,"srcMesh")
call ESMF_MeshWrite(dstMesh,"dstMesh")
#endif
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
srcMaskValues=(/1/), &
dstField=dstField, &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
errorTot=0.0
dstmass = 0.
! get dst Field
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstAreaField, 0, dstAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, 0, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1)*fptr(i1)
! Instead do this
dstmass = dstmass + dstAreaptr(i1)*dstFarrayPtr(i1)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1) .lt. 0.999) cycle
! write(*,*) i1,"::",dstFarrayPtr(i1),xdstFarrayPtr(i1)
if (xdstFarrayPtr(i1) .ne. 0.0) then
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
else
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
endif
enddo
srcmass(1) = 0.
! get src pointer
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcAreaField, 0, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, 0, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
srcmass(1) = srcmass(1) + srcFracptr(i1)*srcAreaptr(i1)*srcFarrayPtr(i1)
enddo
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Cartesian Mesh with Masks and Fractions ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the meshes
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return success if we've gotten this far
rc=ESMF_SUCCESS
end subroutine test_RegridCsrvCartMesh
subroutine test_sph_csrv_w_frac_norm(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Grid) :: srcGrid
type(ESMF_Grid) :: dstGrid
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: dstFracField
type(ESMF_Field) :: srcFracField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: errorField
type(ESMF_Field) :: srcArea, dstArea
type(ESMF_Array) :: dstArray
type(ESMF_Array) :: xdstArray
type(ESMF_Array) :: errorArray
type(ESMF_Array) :: srcArray
type(ESMF_Array) :: srcAreaArray, dstAreaArray
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
integer(ESMF_KIND_I4), pointer :: srcMask(:,:), dstMask(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtrXC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtrYC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtr(:,:),xfarrayPtr(:,:),errorfarrayPtr(:,:),iwtsptr(:,:)
real(ESMF_KIND_R8), pointer :: srcAreaptr(:,:), dstAreaptr(:,:)
real(ESMF_KIND_R8), pointer :: srcFracptr(:,:), dstFracptr(:,:)
integer :: petMap2D(2,2,1)
integer :: clbnd(2),cubnd(2)
integer :: fclbnd(2),fcubnd(2)
integer :: i1,i2, index(2)
integer :: lDE, localDECount, i
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
integer :: Src_nx, Src_ny
integer :: Dst_nx, Dst_ny
real(ESMF_KIND_R8) :: Src_dx, Src_dy, yp1
real(ESMF_KIND_R8) :: Dst_dx, Dst_dy
real(ESMF_KIND_R8) :: ctheta, stheta
real(ESMF_KIND_R8) :: theta, d2rad, x, y, z
real(ESMF_KIND_R8) :: DEG2RAD, a, lat, lon, phi
real(ESMF_KIND_R8) :: xtmp, ytmp, ztmp
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
integer :: spherical_grid
integer, pointer :: larrayList(:)
integer :: localPet, petCount
! result code
integer :: finalrc
! init success flag
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Establish the resolution of the grids
Src_nx = 180
Src_ny = 100
Src_dx = 360.0/Src_nx
Src_dy = 180.0/Src_ny
Dst_nx = 100
Dst_ny = 80
Dst_dx = 360.0/Dst_nx
Dst_dy = 180.0/Dst_ny
! degree to rad conversion
DEG2RAD = 3.141592653589793_ESMF_KIND_R8/180.0_ESMF_KIND_R8
! setup source grid
srcGrid=ESMF_GridCreate1PeriDim(minIndex=(/1,1/),maxIndex=(/src_nx,src_ny/),regDecomp=(/petCount,1/), &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! setup dest. grid
dstGrid=ESMF_GridCreate1PeriDim(minIndex=(/1,1/),maxIndex=(/dst_nx,dst_ny/),regDecomp=(/1,petCount/), &
coordSys=ESMF_COORDSYS_SPH_DEG, &
indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source/destination fields
call ESMF_ArraySpecSet(arrayspec, 2, ESMF_TYPEKIND_R8, rc=rc)
srcField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcFracField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
srcArea = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
errorField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstFracField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
xdstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
dstArea = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Allocate coordinates
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Add Masks
call ESMF_GridAddItem(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridAddItem(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get number of local DEs
call ESMF_GridGet(srcGrid, localDECount=localDECount, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get arrays
! dstArray
call ESMF_FieldGet(dstField, array=dstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! srcArray
call ESMF_FieldGet(srcField, array=srcArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! xdstArray
call ESMF_FieldGet(xdstField, array=xdstArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! errorArray
call ESMF_FieldGet(errorField, array=errorArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(srcArea, array=srcAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! area Array
call ESMF_FieldGet(dstArea, array=dstAreaArray, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Source Grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Construct 3D Grid A
! (Get memory and set coords for src)
do lDE=0,localDECount-1
!! get coord 1
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Src_dx
farrayPtrYC(i1,i2) = REAL(i2-1)*Src_dy - 90.0
enddo
enddo
!! DO CENTER STAGGER STUFF
!! get coord 1
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src pointer
call ESMF_FieldGet(srcField, lDE, farrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetItem(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=srcMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
y= REAL(i2-1)*Src_dy - 90.0
yp1= REAL(i2-1+1)*Src_dy - 90.0
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Src_dx + 0.5*Src_dx
farrayPtrYC(i1,i2) = (y+yp1)/2.0
! set src data
lon = farrayPtrXC(i1,i2)
lat = farrayPtrYC(i1,i2)
! Set the source to be a function of the x,y,z coordinate
theta = DEG2RAD*(lon)
phi = DEG2RAD*(90.-lat)
! set src data
! farrayPtr(i1,i2) = 1.
farrayPtr(i1,i2) = 2. + cos(theta)**2.*cos(2.*phi)
if ((lat>-45) .and. (lat<45)) then
srcMask(i1,i2)=1
else
srcMask(i1,i2)=0
endif
enddo
enddo
enddo ! lDE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Destination grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Get memory and set coords for dst
do lDE=0,localDECount-1
!! get coords
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set dest coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Dst_dx
farrayPtrYC(i1,i2) = REAL(i2-1)*Dst_dy - 90.0
enddo
enddo
!! DO CENTER STAGGER STUFF
!! get coord 1
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=dstMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst pointer
call ESMF_FieldGet(dstField, lDE, farrayPtr, computationalLBound=fclbnd, &
computationalUBound=fcubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact pointer
call ESMF_FieldGet(xdstField, lDE, xfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
y= REAL(i2-1)*Dst_dy - 90.0
yp1= REAL(i2-1+1)*Dst_dy - 90.0
! Set source coordinates
farrayPtrXC(i1,i2) = REAL(i1-1)*Dst_dx + 0.5*Dst_dx
farrayPtrYC(i1,i2) = (y+yp1)/2.0
! init dst data
farrayPtr(i1,i2) = 0.0
! init exact answer
lon = farrayPtrXC(i1,i2)
lat = farrayPtrYC(i1,i2)
! Set the source to be a function of the x,y,z coordinate
theta = DEG2RAD*(lon)
phi = DEG2RAD*(90.-lat)
! set exact dst data
xfarrayPtr(i1,i2) = 2. + cos(theta)**2.*cos(2.*phi)
! xfarrayPtr(i1,i2) = 1.0
if ((lon>-45) .and. (lon<45)) then
dstMask(i1,i2)=1
else
dstMask(i1,i2)=0
endif
enddo
enddo
enddo ! lDE
! Regrid store
call ESMF_FieldRegridStore(srcField, srcMaskValues=(/1/), &
dstField=dstField, dstMaskValues=(/1/), &
routeHandle=routeHandle, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
normType=ESMF_NORMTYPE_FRACAREA, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
do lDE=0,localDECount-1
! get dst Field
call ESMF_FieldGet(dstField, lDE, farrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, lDE, xfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get destination mask field
call ESMF_GridGetItem(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, &
itemflag=ESMF_GRIDITEM_MASK, farrayPtr=dstMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get error Field
call ESMF_FieldGet(errorField, lDE, errorfarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstArea, lDE, dstAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, lDE, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
dstmass = 0.
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! skip if masked
if (dstMask(i1,i2) .eq. 1) cycle
! Calculate total mass
! NOTE: DO need to include dstFrac here, because the frac has been included in the weights
dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1,i2)*farrayPtr(i1,i2)
! If this destination cell isn't covered by a reasonable amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1,i2) .lt. 0.001) cycle
if (xfarrayPtr(i1,i2) .ne. 0.0) then
errorfarrayPtr(i1,i2)=ABS(farrayPtr(i1,i2) &
- xfarrayPtr(i1,i2))/ABS(xfarrayPtr(i1,i2))
error = error + errorfarrayPtr(i1,i2)
if (errorfarrayPtr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfarrayPtr(i1,i2)
endif
if (errorfarrayPtr(i1,i2) < minerror(1)) then
minerror(1) = errorfarrayPtr(i1,i2)
endif
else
errorfarrayPtr(i1,i2)=ABS((farrayPtr(i1,i2)/dstFracPtr(i1,i2)) - xfarrayPtr(i1,i2))
error = error + errorfarrayPtr(i1,i2)
if (errorfarrayPtr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfarrayPtr(i1,i2)
endif
if (errorfarrayPtr(i1,i2) < minerror(1)) then
minerror(1) = errorfarrayPtr(i1,i2)
endif
endif
enddo
enddo
enddo ! lDE
srcmass(1) = 0.
do lDE=0,localDECount-1
! get src pointer
call ESMF_FieldGet(srcField, lDE, farrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcArea, lDE, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, lDE, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
srcmass(1) = srcmass(1) + srcFracptr(i1,i2)*srcAreaptr(i1,i2)*farrayPtr(i1,i2)
enddo
enddo
enddo ! lDE
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Spherical grids with frac normalization ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
#if 0
spherical_grid = 1
call ESMF_MeshIO(vm, srcGrid, ESMF_STAGGERLOC_CENTER, &
"srcmesh", srcArray, srcAreaArray, rc=localrc, &
spherical=spherical_grid)
call ESMF_MeshIO(vm, dstGrid, ESMF_STAGGERLOC_CENTER, &
"dstmesh", dstArray, xdstArray, errorArray, dstAreaarray, rc=localrc, &
spherical=spherical_grid)
#endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(errorField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the grids
call ESMF_GridDestroy(srcGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridDestroy(dstGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
end subroutine test_sph_csrv_w_frac_norm
subroutine test_RegridCsrvCartPHFracNorm(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Mesh) :: srcMesh
type(ESMF_Mesh) :: dstMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: srcAreaField, dstAreaField
type(ESMF_Field) :: srcFracField, dstFracField
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: srcFarrayPtr(:), dstFarrayPtr(:), xdstFarrayPtr(:)
real(ESMF_KIND_R8), pointer :: srcAreaPtr(:), dstAreaPtr(:)
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
integer :: i1,i2,i3
real(ESMF_KIND_R8) :: x,y,z
integer :: localPet, petCount
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
real(ESMF_KIND_R8) :: errorTot, errorTotG
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes
integer :: iconn,inode
integer :: numQuadElems,numTriElems
integer :: numPentElems,numHexElems,numTotElems
integer :: numElemConn
! result code
integer :: finalrc
! Init to success
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
! Setup source mesh
! Src Mesh
!
! 2.5 8 10 --------11
! / \ / |
! 2.1 7 9 12
! | | 5 /
! | 4 | /
! | | /
! 1.0 4 ------- 5 ------- 6
! | | \ 3 |
! | 1 | \ |
! | | 2 \ |
! -0.1 1 ------- 2 ------- 3
!
! -0.1 1.0 2.1 2.5
!
! Node Id labels at corners
! Element Id labels in centers
! Setup Src Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=12
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9,10,11,12/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1,-0.1, & ! node id 1
1.0,-0.1, & ! node id 2
2.1,-0.1, & ! node id 3
-0.1, 1.0, & ! node id 4
1.0, 1.0, & ! node id 5
2.1, 1.0, & ! node id 6
-0.1, 2.1, & ! node id 7
0.5, 2.5, & ! node id 8
1.0, 2.1, & ! node id 9
1.5, 2.5, & ! node id 10
2.5, 2.5, & ! node id 11
2.5, 2.1/) ! node id 12
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus tot and num conn.
numQuadElems=1
numTriElems=2
numPentElems=1
numHexElems=1
numTotElems=numTriElems+numQuadElems+numPentElems+numHexElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+6*numHexElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0,1,0,0,0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
5, & ! elem id 4
6/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,9,8,7, & ! elem id 4
5,6,12,11,10,9/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1, -0.1, & ! node id 1
1.0, -0.1, & ! node id 2
-0.1, 1.0, & ! node id 4
1.0, 1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus tot and num conn.
numQuadElems=1
numTriElems=0
numPentElems=0
numHexElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numHexElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+6*numHexElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,-0.1, & ! node id 2
2.1,-0.1, & ! node id 3
1.0, 1.0, & ! node id 5
2.1, 1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=2
numPentElems=0
numHexElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numHexElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+6*numHexElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/1,0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=5
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1,1.0, & ! node id 4
1.0,1.0, & ! node id 5
-0.1,2.1, & ! node id 7
0.5,2.5, & ! node id 8
1.0,2.1 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2, & ! node id 8
2/) ! node id 9
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=0
numPentElems=1
numHexElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numHexElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+6*numHexElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/5/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=6
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,9,10,11,12/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.1,1.0, & ! node id 6
1.0,2.1, & ! node id 9
1.5,2.5, & ! node id 10
2.5,2.5, & ! node id 11
2.5,2.1 /) ! node id 12
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 9
3, & ! node id 10
3, & ! node id 11
3/) ! node id 12
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=0
numPentElems=0
numHexElems=1
numTotElems=numTriElems+numQuadElems+numPentElems+numHexElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+6*numHexElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element Mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/6/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,6,5,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
elementMask=elemMask, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec for fields
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create source field
srcField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source area field
srcAreaField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Load test data into the source Field
! Should only be 1 localDE
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
! (Set huge value for masked values, so it can be detected)
if (elemMask(i1) .eq. 0) then
srcFarrayPtr(i1) = 20.0+x+y
else
srcFarrayPtr(i1) = 100000000.0
endif
enddo
! For now, Easy set interpolated function
!srcFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
deallocate(elemMask)
!!!!!!!!!!!!!!! Setup Destination Mesh !!!!!!!!!!!!!!!!!
! Dest Mesh
!
! 2.0 7 ------- 8 ------- 9
! | | \
! 1.5 | 4 | 5 10
! | | /
! 1.0 4 ------- 5 ------- 6
! | | \ 3 |
! | 1 | \ |
! | | 2 \ |
! 0.0 1 ------- 2 ------- 3
!
! 0.0 1.0 2.0 3.0
!
! Node Id labels at corners
! Element Id labels in centers
! Create Dest Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=10
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9,10/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
0.0,1.0, & ! node id 4
1.0,1.0, & ! node id 5
2.0,1.0, & ! node id 6
0.0,2.0, & ! node id 7
1.0,2.0, & ! node id 8
2.0,2.0, & ! node id 9
3.0,1.5 /) ! node id 10
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numTriElems=2
numQuadElems=2
numPentElems=1
numTotElems=numTriElems+numQuadElems+numPentElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
5/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,10,9,8/)! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
0.0,1.0, & ! node id 4
1.0,1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=1
numPentElems=0
numTotElems=numTriElems+numQuadElems+numPentElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
1.0,1.0, & ! node id 5
2.0,1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numTriElems=2
numQuadElems=0
numPentElems=0
numTotElems=numTriElems+numQuadElems+numPentElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,1.0, & ! node id 4
1.0,1.0, & ! node id 5
0.0,2.0, & ! node id 7
1.0,2.0 /) ! node id 8
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=1
numPentElems=0
numTotElems=numTriElems+numQuadElems+numPentElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=5
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9,10/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.0,1.0, & ! node id 6
1.0,2.0, & ! node id 8
2.0,2.0, & ! node id 9
3.0,1.5 /) ! node id 10
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3, & ! node id 9
3/) ! node id 10
! Set the number of each type of element, plus the total number.
numTriElems=0
numQuadElems=0
numPentElems=1
numTotElems=numTriElems+numQuadElems+numPentElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numElemConn))
elemTypes=(/5/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create dest. field
dstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. area field
dstAreaField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create exact dest. field
xdstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="xdest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
! Should only be 1 localDE
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
dstFarrayPtr=0.0
! Init exact destination field
! Should only be 1 localDE
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
xdstFarrayPtr(i1) = 20.0+x+y
enddo
! For now, Easy set interpolated function
!xdstFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
#if 0
call ESMF_MeshWrite(srcMesh,"srcMesh")
call ESMF_MeshWrite(dstMesh,"dstMesh")
#endif
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
srcMaskValues=(/1/), &
dstField=dstField, &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
normType=ESMF_NORMTYPE_FRACAREA, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
errorTot=0.0
dstmass = 0.
! get dst Field
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstAreaField, 0, dstAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, 0, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
! Here do include frac, because we're doing frac norm option
dstmass = dstmass + dstFracptr(i1)*dstAreaptr(i1)*dstFarrayPtr(i1)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1) .lt. 0.1) cycle
! write(*,*) i1,"::",dstFarrayPtr(i1),xdstFarrayPtr(i1)
if (xdstFarrayPtr(i1) .ne. 0.0) then
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
else
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
endif
enddo
srcmass(1) = 0.
! get src pointer
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcAreaField, 0, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, 0, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
srcmass(1) = srcmass(1) + srcFracptr(i1)*srcAreaptr(i1)*srcFarrayPtr(i1)
enddo
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Mesh with Pentagons and Hexagons using frac. normalization ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the meshes
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return success if we've gotten this far
rc=ESMF_SUCCESS
end subroutine test_RegridCsrvCartPHFracNorm
subroutine test_RegridCart4ConcaveMesh(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Mesh) :: srcMesh
type(ESMF_Mesh) :: dstMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: srcAreaField, dstAreaField
type(ESMF_Field) :: srcFracField, dstFracField
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: srcFarrayPtr(:), dstFarrayPtr(:), xdstFarrayPtr(:)
real(ESMF_KIND_R8), pointer :: srcAreaPtr(:), dstAreaPtr(:)
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
integer :: i1,i2,i3
real(ESMF_KIND_R8) :: x,y,z
integer :: localPet, petCount
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
real(ESMF_KIND_R8) :: errorTot, errorTotG
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes
integer :: iconn,inode
integer :: numQuadElems,numTriElems
integer :: numPentElems,numHexElems,numTotElems
integer :: numElemConn
! result code
integer :: finalrc
! Init to success
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
! XMRKX
!!!! Setup source mesh !!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Creates the following mesh on
! 1 or 4 PETs. Returns an error
! if run on other than 1 or 4 PETs
!
! Mesh Ids
!
! 2.0 7 ------- 8
! | |\
! 1.3 | 3 | 9
! | |4 \
! 1.0 4 ------- 5 -------- 6
! | | |
! | 1 | 2 |
! | | |
! 0.0 1 ------- 2 -------- 3
!
! 0.0 1.0 1.3 2.0
!
! Node Ids at corners
! Element Ids in centers
!
!!!!!
!
! The owners for 1 PET are all Pet 0.
! The owners for 4 PETs are as follows:
!
! Mesh Owners
!
! 2.0 2 ------- 2
! | |\
! 1.3 | 2 | 3
! | |3 \
! 1.0 0 ------- 0 -------- 1
! | | |
! | 0 | 1 |
! | | |
! 0.0 0 ------- 0 -------- 1
!
! 0.0 1.0 1.3 2.0
!
! Node Owners at corners
! Element Owners in centers
!
! Setup mesh info depending on the
! number of PETs
if (petCount .eq. 1) then
! Fill in node data
numNodes=9
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, &
1.0,0.0, &
2.0,0.0, &
0.0,1.0, &
1.0,1.0, &
2.0,1.0, &
0.0,2.0, &
1.0,2.0, &
1.3,1.3 /)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on proc 0
! Fill in elem data
numTotElems=4
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4/)
!! elem types
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,5,4, &
2,3,6,5, &
4,5,8,7, &
5,6,9,8/)
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPet .eq. 0) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, &
1.0,0.0, &
0.0,1.0, &
1.0,1.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,0,0,0/) ! everything on proc 0
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/1/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else if (localPet .eq. 1) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/1.0,0.0, &
2.0,0.0, &
1.0,1.0, &
2.0,1.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,1,0,1/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/2/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else if (localPet .eq. 2) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,1.0, &
1.0,1.0, &
0.0,2.0, &
1.0,2.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,0,2,2/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/3/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/1.0,1.0, &
2.0,1.0, &
1.0,2.0, &
1.3,1.3/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,1,2,3/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/4/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
rc=rc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec for fields
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create source field
srcField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source area field
srcAreaField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Load test data into the source Field
! Should only be 1 localDE
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
srcFarrayPtr(i1) = 20.0+x+y
enddo
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
!!!!!!!!!!!!!!! Setup Destination Mesh !!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Creates the following mesh on
! 1 or 4 PETs. Returns an error
! if run on other than 1 or 4 PETs
!
! Mesh Ids
!
! 2.0 7 ------- 8
! | |\
! 1.4 | 3 | 9
! | |4 \
! 1.0 4 ------- 5 -------- 6
! | | |
! | 1 | 2 |
! | | |
! 0.0 1 ------- 2 -------- 3
!
! 0.0 1.0 1.4 2.0
!
! Node Ids at corners
! Element Ids in centers
!
!!!!!
!
! The owners for 1 PET are all Pet 0.
! The owners for 4 PETs are as follows:
!
! Mesh Owners
!
! 2.0 2 ------- 2
! | |\
! 1.4 | 2 | 3
! | |3 \
! 1.0 0 ------- 0 -------- 1
! | | |
! | 0 | 1 |
! | | |
! 0.0 0 ------- 0 -------- 1
!
! 0.0 1.0 1.4 2.0
!
! Node Owners at corners
! Element Owners in centers
!
! Setup mesh info depending on the
! number of PETs
if (petCount .eq. 1) then
! Fill in node data
numNodes=9
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, &
1.0,0.0, &
2.0,0.0, &
0.0,1.0, &
1.0,1.0, &
2.0,1.0, &
0.0,2.0, &
1.0,2.0, &
1.4,1.4 /)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on proc 0
! Fill in elem data
numTotElems=4
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4/)
!! elem types
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,5,4, &
2,3,6,5, &
4,5,8,7, &
5,6,9,8/)
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPet .eq. 0) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, &
1.0,0.0, &
0.0,1.0, &
1.0,1.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,0,0,0/) ! everything on proc 0
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/1/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else if (localPet .eq. 1) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/1.0,0.0, &
2.0,0.0, &
1.0,1.0, &
2.0,1.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,1,0,1/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/2/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else if (localPet .eq. 2) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,1.0, &
1.0,1.0, &
0.0,2.0, &
1.0,2.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,0,2,2/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/3/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/1.0,1.0, &
2.0,1.0, &
1.0,2.0, &
1.4,1.4/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,1,2,3/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/4/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create dest. field
dstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. area field
dstAreaField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create exact dest. field
xdstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="xdest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
! Should only be 1 localDE
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
dstFarrayPtr=0.0
! Init exact destination field
! Should only be 1 localDE
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
xdstFarrayPtr(i1) = 20.0+x+y
enddo
! For now, Easy set interpolated function
!xdstFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
#if 0
call ESMF_MeshWrite(srcMesh,"srcMesh")
call ESMF_MeshWrite(dstMesh,"dstMesh")
#endif
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
srcMaskValues=(/1/), &
dstField=dstField, &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
errorTot=0.0
dstmass = 0.
! get dst Field
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstAreaField, 0, dstAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, 0, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1)*fptr(i1)
! Instead do this
dstmass = dstmass + dstAreaptr(i1)*dstFarrayPtr(i1)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1) .lt. 0.999) cycle
! write(*,*) i1,"::",dstFarrayPtr(i1),xdstFarrayPtr(i1)
if (xdstFarrayPtr(i1) .ne. 0.0) then
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
else
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
endif
enddo
srcmass(1) = 0.
! get src pointer
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcAreaField, 0, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, 0, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
srcmass(1) = srcmass(1) + srcFracptr(i1)*srcAreaptr(i1)*srcFarrayPtr(i1)
enddo
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Mesh with concave quads ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the meshes
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return success if we've gotten this far
rc=ESMF_SUCCESS
end subroutine test_RegridCart4ConcaveMesh
subroutine test_RegridSph4ConcaveMesh(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Mesh) :: srcMesh
type(ESMF_Mesh) :: dstMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: srcAreaField, dstAreaField
type(ESMF_Field) :: srcFracField, dstFracField
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: srcFarrayPtr(:), dstFarrayPtr(:), xdstFarrayPtr(:)
real(ESMF_KIND_R8), pointer :: srcAreaPtr(:), dstAreaPtr(:)
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
integer :: i1,i2,i3
real(ESMF_KIND_R8) :: x,y,z
integer :: localPet, petCount
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
real(ESMF_KIND_R8) :: errorTot, errorTotG
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes
integer :: iconn,inode
integer :: numQuadElems,numTriElems
integer :: numPentElems,numHexElems,numTotElems
integer :: numElemConn
! result code
integer :: finalrc
! Init to success
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
! XMRKX
!!!! Setup source mesh !!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Creates the following mesh on
! 1 or 4 PETs. Returns an error
! if run on other than 1 or 4 PETs
!
! Mesh Ids
!
! 20 7 ------- 8
! | |\
! 13 | 3 | 9
! | |4 \
! 10 4 ------- 5 -------- 6
! | | |
! | 1 | 2 |
! | | |
! 0.0 1 ------- 2 -------- 3
!
! 0.0 10 13 20
!
! Node Ids at corners
! Element Ids in centers
!
!!!!!
!
! The owners for 1 PET are all Pet 0.
! The owners for 4 PETs are as follows:
!
! Mesh Owners
!
! 20 2 ------- 2
! | |\
! 12 | 2 | 3
! | |3 \
! 10 0 ------- 0 -------- 1
! | | |
! | 0 | 1 |
! | | |
! 0.0 0 ------- 0 -------- 1
!
! 0.0 10 12 20
!
! Node Owners at corners
! Element Owners in centers
!
! Setup mesh info depending on the
! number of PETs
if (petCount .eq. 1) then
! Fill in node data
numNodes=9
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, &
10.0,0.0, &
20.0,0.0, &
0.0,10.0, &
10.0,10.0, &
20.0,10.0, &
0.0,20.0, &
10.0,20.0, &
12.0,12.0 /)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on proc 0
! Fill in elem data
numTotElems=4
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4/)
!! elem types
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,5,4, &
2,3,6,5, &
4,5,8,7, &
5,6,9,8/)
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPet .eq. 0) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, &
10.0,0.0, &
0.0,10.0, &
10.0,10.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,0,0,0/) ! everything on proc 0
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/1/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else if (localPet .eq. 1) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/10.0,0.0, &
20.0,0.0, &
10.0,10.0, &
20.0,10.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,1,0,1/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/2/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else if (localPet .eq. 2) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,10.0, &
10.0,10.0, &
0.0,20.0, &
10.0,20.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,0,2,2/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/3/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/10.0,10.0, &
20.0,10.0, &
10.0,20.0, &
12.0,12.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,1,2,3/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/4/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
rc=rc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec for fields
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create source field
srcField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source area field
srcAreaField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Load test data into the source Field
! Should only be 1 localDE
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
srcFarrayPtr(i1) = 20.0+x+y
enddo
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
!!!!!!!!!!!!!!! Setup Destination Mesh !!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Creates the following mesh on
! 1 or 4 PETs. Returns an error
! if run on other than 1 or 4 PETs
!
! Mesh Ids
!
! 20.0 7 ------- 8
! | |\
! 14.0 | 3 | 9
! | |4 \
! 10.0 4 ------- 5 -------- 6
! | | |
! | 1 | 2 |
! | | |
! 0.0 1 ------- 2 -------- 3
!
! 0.0 10.0 14.0 20.0
!
! Node Ids at corners
! Element Ids in centers
!
!!!!!
!
! The owners for 1 PET are all Pet 0.
! The owners for 4 PETs are as follows:
!
! Mesh Owners
!
! 20.0 2 ------- 2
! | |\
! 14.0 | 2 | 3
! | |3 \
! 10.0 0 ------- 0 -------- 1
! | | |
! | 0 | 1 |
! | | |
! 0.0 0 ------- 0 -------- 1
!
! 0.0 10.0 14.0 20.0
!
! Node Owners at corners
! Element Owners in centers
!
! Setup mesh info depending on the
! number of PETs
if (petCount .eq. 1) then
! Fill in node data
numNodes=9
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, &
10.0,0.0, &
20.0,0.0, &
0.0,10.0, &
10.0,10.0, &
20.0,10.0, &
0.0,20.0, &
10.0,20.0, &
14.0,14.0 /)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on proc 0
! Fill in elem data
numTotElems=4
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4/)
!! elem types
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,5,4, &
2,3,6,5, &
4,5,8,7, &
5,6,9,8/)
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPet .eq. 0) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, &
10.0,0.0, &
0.0,10.0, &
10.0,10.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,0,0,0/) ! everything on proc 0
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/1/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else if (localPet .eq. 1) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/10.0,0.0, &
20.0,0.0, &
10.0,10.0, &
20.0,10.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,1,0,1/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/2/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else if (localPet .eq. 2) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,10.0, &
10.0,10.0, &
0.0,20.0, &
10.0,20.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,0,2,2/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/3/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/10.0,10.0, &
20.0,10.0, &
10.0,20.0, &
14.0,14.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,1,2,3/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/4/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create dest. field
dstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. area field
dstAreaField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create exact dest. field
xdstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="xdest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
! Should only be 1 localDE
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
dstFarrayPtr=0.0
! Init exact destination field
! Should only be 1 localDE
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
xdstFarrayPtr(i1) = 20.0+x+y
enddo
! For now, Easy set interpolated function
!xdstFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
#if 0
call ESMF_MeshWrite(srcMesh,"srcMesh")
call ESMF_MeshWrite(dstMesh,"dstMesh")
#endif
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
srcMaskValues=(/1/), &
dstField=dstField, &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
errorTot=0.0
dstmass = 0.
! get dst Field
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstAreaField, 0, dstAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, 0, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1)*fptr(i1)
! Instead do this
dstmass = dstmass + dstAreaptr(i1)*dstFarrayPtr(i1)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1) .lt. 0.999) cycle
! write(*,*) i1,"::",dstFarrayPtr(i1),xdstFarrayPtr(i1)
if (xdstFarrayPtr(i1) .ne. 0.0) then
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
else
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
endif
enddo
srcmass(1) = 0.
! get src pointer
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcAreaField, 0, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, 0, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
srcmass(1) = srcmass(1) + srcFracptr(i1)*srcAreaptr(i1)*srcFarrayPtr(i1)
enddo
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Mesh with concave quads ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the meshes
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return success if we've gotten this far
rc=ESMF_SUCCESS
end subroutine test_RegridSph4ConcaveMesh
subroutine test_MOABMeshToMesh(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Mesh) :: srcMesh
type(ESMF_Mesh) :: dstMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: srcAreaField, dstAreaField
type(ESMF_Field) :: srcFracField, dstFracField
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: srcFarrayPtr(:), dstFarrayPtr(:), xdstFarrayPtr(:)
real(ESMF_KIND_R8), pointer :: srcAreaPtr(:), dstAreaPtr(:)
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
integer :: i1,i2,i3
real(ESMF_KIND_R8) :: x,y,z
integer :: localPet, petCount
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
real(ESMF_KIND_R8) :: errorTot, errorTotG
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes
integer :: iconn,inode
integer :: numQuadElems,numTriElems
integer :: numPentElems,numHexElems,numTotElems
integer :: numElemConn
! result code
integer :: finalrc
! Init to success
rc=ESMF_SUCCESS
itrp=.true.
csrv=.true.
! Don't do the test is MOAB isn't available
#ifdef ESMF_MOAB
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
rc=ESMF_SUCCESS
return
endif
! Turn on MOAB
call ESMF_MeshSetMOAB(.true., rc=localrc)
if (localrc .ne. ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
!!!! Setup source mesh !!!!
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
0.0, 1.0, & ! node id 4
1.0, 1.0, & ! node id 5
2.0, 1.0, & ! node id 6
0.0, 2.0, & ! node id 7
1.0, 2.0, & ! node id 8
2.0, 2.0 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numQuadElems=3
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0, 0.0, & ! node id 1
1.0, 0.0, & ! node id 2
0.0, 1.0, & ! node id 4
1.0, 1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
1.0, 1.0, & ! node id 5
2.0, 1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numQuadElems=0
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,1.0, & ! node id 4
1.0,1.0, & ! node id 5
0.0,2.0, & ! node id 7
1.0,2.0 /) ! node id 8
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.0,1.0, & ! node id 6
1.0,2.0, & ! node id 8
2.0,2.0 /) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
rc=rc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec for fields
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create source field
srcField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source area field
srcAreaField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Load test data into the source Field
! Should only be 1 localDE
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
srcFarrayPtr(i1) = 20.0+x+y
enddo
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
!!!!!!!!!!!!!!! Setup Destination Mesh !!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Creates the following mesh on
! 1 or 4 PETs. Returns an error
! if run on other than 1 or 4 PETs
!
! Mesh Ids
!
! 2.0 7 ------- 8 -------- 9
! | | |
! | 3 | 4 |
! | | |
! 1.0 4 ------- 5 -------- 6
! | | |
! | 1 | 2 |
! | | |
! 0.0 1 ------- 2 -------- 3
!
! 0.0 1.0 2.0
!
! Node Ids at corners
! Element Ids in centers
!
!!!!!
!
! The owners for 1 PET are all Pet 0.
! The owners for 4 PETs are as follows:
!
! Mesh Owners
!
! 2.0 2 ------- 2--------- 3
! | | |
! | 2 | 3 |
! | | |
! 1.0 0 ------- 0 -------- 1
! | | |
! | 0 | 1 |
! | | |
! 0.0 0 ------- 0 -------- 1
!
! 0.0 1.0 2.0
!
! Node Owners at corners
! Element Owners in centers
!
! Setup mesh info depending on the
! number of PETs
if (petCount .eq. 1) then
! Fill in node data
numNodes=9
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, &
1.0,0.0, &
2.0,0.0, &
0.0,1.0, &
1.0,1.0, &
2.0,1.0, &
0.0,2.0, &
1.0,2.0, &
2.0,2.0 /)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on proc 0
! Fill in elem data
numTotElems=4
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4/)
!! elem types
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,5,4, &
2,3,6,5, &
4,5,8,7, &
5,6,9,8/)
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPet .eq. 0) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, &
1.0,0.0, &
0.0,1.0, &
1.0,1.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,0,0,0/) ! everything on proc 0
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/1/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else if (localPet .eq. 1) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/1.0,0.0, &
2.0,0.0, &
1.0,1.0, &
2.0,1.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,1,0,1/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/2/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else if (localPet .eq. 2) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,1.0, &
1.0,1.0, &
0.0,2.0, &
1.0,2.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,0,2,2/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/3/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
else
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/1.0,1.0, &
2.0,1.0, &
1.0,2.0, &
2.0,2.0/)
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0,1,2,3/)
! Fill in elem data
numTotElems=1
!! elem ids
allocate(elemIds(numTotElems))
elemIds=(/4/)
!! elem type
allocate(elemTypes(numTotElems))
elemTypes=ESMF_MESHELEMTYPE_QUAD
!! elem conn
allocate(elemConn(numTotElems*4))
elemConn=(/1,2,4,3/)
endif
endif
! XMRKX
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshSetMOAB(.false., rc=localrc)
if (localrc .ne. ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create dest. field
dstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. area field
dstAreaField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create exact dest. field
xdstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="xdest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
! Should only be 1 localDE
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
dstFarrayPtr=0.0
! Init exact destination field
! Should only be 1 localDE
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
do i2=1,elemTypes(i1)
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
iconn=iconn+1
enddo
x=x*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
y=y*(1.0/REAL(elemTypes(i1),ESMF_KIND_R8))
! Set source function
xdstFarrayPtr(i1) = 20.0+x+y
enddo
! For now, Easy set interpolated function
!xdstFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
#if 0
call ESMF_MeshWrite(srcMesh,"srcMesh")
call ESMF_MeshWrite(dstMesh,"dstMesh")
#endif
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
dstField=dstField, &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
! COMMENT THESE OUT UNTIL THAT PART IS WORKING
! dstFracField=dstFracField, &
! srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
#if 1
! Get the integration weights
call ESMF_FieldRegridGetArea(srcAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
#endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
errorTot=0.0
dstmass = 0.
! get dst Field
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstAreaField, 0, dstAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, 0, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1)*fptr(i1)
! Instead do this
dstmass = dstmass + dstAreaptr(i1)*dstFarrayPtr(i1)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
!if (dstFracptr(i1) .lt. 0.999) cycle
! write(*,*) i1,"::",dstFarrayPtr(i1),xdstFarrayPtr(i1)
if (xdstFarrayPtr(i1) .ne. 0.0) then
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
else
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
endif
enddo
srcmass(1) = 0.
! get src pointer
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcAreaField, 0, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, 0, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
! srcmass(1) = srcmass(1) + srcFracptr(i1)*srcAreaptr(i1)*srcFarrayPtr(i1)
srcmass(1) = srcmass(1) + srcAreaptr(i1)*srcFarrayPtr(i1)
enddo
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== MOAB Mesh ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the meshes
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
#endif
! rc, itrp, csrv init to success above
end subroutine test_MOABMeshToMesh
subroutine test_RegridCsrvCartMultiPoly(itrp, csrv, rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Mesh) :: srcMesh
type(ESMF_Mesh) :: dstMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: srcAreaField, dstAreaField
type(ESMF_Field) :: srcFracField, dstFracField
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: srcFarrayPtr(:), dstFarrayPtr(:), xdstFarrayPtr(:)
real(ESMF_KIND_R8), pointer :: srcAreaPtr(:), dstAreaPtr(:)
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
integer :: i1,i2,i3
real(ESMF_KIND_R8) :: x,y,z
integer :: localPet, petCount
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
real(ESMF_KIND_R8) :: errorTot, errorTotG
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes
integer :: iconn,inode, num_conn
integer :: numQuadElems,numTriElems,numMultiElems
integer :: numPentElems,numHexElems,numTotElems
integer :: numElemConn
! result code
integer :: finalrc
! Init to success
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
! Setup source mesh
!
! 2.5 8 10 --------11
! / \ \ |
! 2.1 7 9 \ 12
! | | \ 5
! | 4 | \
! | | \
! 1.0 4 ------- 5 ------- 6
! | | \ 3 |
! | 1 | \ |
! | | 2 \ |
! -0.1 1 ------- 2 ------- 3
!
! -0.1 1.0 2.1 2.5
!
! Node Id labels at corners
! Element Id labels in centers
if (petCount .eq. 1) then
! Set number of nodes
numNodes=12
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9,10,11,12/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1,-0.1, & ! node id 1
1.0,-0.1, & ! node id 2
2.1,-0.1, & ! node id 3
-0.1, 1.0, & ! node id 4
1.0, 1.0, & ! node id 5
2.1, 1.0, & ! node id 6
-0.1, 2.1, & ! node id 7
0.5, 2.5, & ! node id 8
1.0, 2.1, & ! node id 9
1.5, 2.5, & ! node id 10
2.5, 2.5, & ! node id 11
2.5, 2.1/) ! node id 12
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus tot and num conn.
numQuadElems=1
numTriElems=2
numPentElems=1
numMultiElems=1
numTotElems=numTriElems+numQuadElems+numPentElems+numMultiElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+7*numMultiElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
5, & ! elem id 4
7/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,9,8,7, & ! elem id 4
5,6,9,ESMF_MESH_POLYBREAK,12,11,10/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1, -0.1, & ! node id 1
1.0, -0.1, & ! node id 2
-0.1, 1.0, & ! node id 4
1.0, 1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus tot and num conn.
numQuadElems=1
numTriElems=0
numPentElems=0
numMultiElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numMultiElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+7*numMultiElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,-0.1, & ! node id 2
2.1,-0.1, & ! node id 3
1.0, 1.0, & ! node id 5
2.1, 1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=2
numPentElems=0
numMultiElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numMultiElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+7*numMultiElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=5
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1,1.0, & ! node id 4
1.0,1.0, & ! node id 5
-0.1,2.1, & ! node id 7
0.5,2.5, & ! node id 8
1.0,2.1 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2, & ! node id 8
2/) ! node id 9
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=0
numPentElems=1
numMultiElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numMultiElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+7*numMultiElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/5/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=6
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,9,10,11,12/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.1,1.0, & ! node id 6
1.0,2.1, & ! node id 9
1.5,2.5, & ! node id 10
2.5,2.5, & ! node id 11
2.5,2.1 /) ! node id 12
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 9
3, & ! node id 10
3, & ! node id 11
3/) ! node id 12
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=0
numPentElems=0
numMultiElems=1
numTotElems=numTriElems+numQuadElems+numPentElems+numMultiElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+7*numMultiElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/7/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,3,ESMF_MESH_POLYBREAK,6,5,4/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec for fields
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create source field
srcField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source area field
srcAreaField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Load test data into the source Field
! Should only be 1 localDE
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! set interpolated function
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
num_conn=0
do i2=1,elemTypes(i1)
if (elemConn(iconn) .ne. ESMF_MESH_POLYBREAK) then
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
num_conn=num_conn+1
endif
iconn=iconn+1
enddo
x=x*(1.0/REAL(num_conn,ESMF_KIND_R8))
y=y*(1.0/REAL(num_conn,ESMF_KIND_R8))
! Set source function
srcFarrayPtr(i1) = 20.0+x+y
enddo
! XMRKX
! For now, Easy set interpolated function
!srcFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
!!!!!!!!!!!!!!! Setup Destination Mesh !!!!!!!!!!!!!!!!!
!
! 2.5 8 10 --------11
! / \ \ |
! 2.1 7 9 \ 12
! | | \ 5
! | 4 | \
! | | \
! 1.0 4 ------- 5 ------- 6
! | | \ 3 |
! | 1 | \ |
! | | 2 \ |
! -0.1 1 ------- 2 ------- 3
!
! -0.1 1.0 2.1 2.5
!
! Node Id labels at corners
! Element Id labels in centers
if (petCount .eq. 1) then
! Set number of nodes
numNodes=12
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9,10,11,12/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1,-0.1, & ! node id 1
1.0,-0.1, & ! node id 2
2.1,-0.1, & ! node id 3
-0.1, 1.0, & ! node id 4
1.0, 1.0, & ! node id 5
2.1, 1.0, & ! node id 6
-0.1, 2.1, & ! node id 7
0.5, 2.5, & ! node id 8
1.0, 2.1, & ! node id 9
1.5, 2.5, & ! node id 10
2.5, 2.5, & ! node id 11
2.5, 2.1/) ! node id 12
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus tot and num conn.
numQuadElems=1
numTriElems=2
numPentElems=1
numMultiElems=1
numTotElems=numTriElems+numQuadElems+numPentElems+numMultiElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+7*numMultiElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
5, & ! elem id 4
7/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,9,8,7, & ! elem id 4
5,6,9,ESMF_MESH_POLYBREAK,12,11,10/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1, -0.1, & ! node id 1
1.0, -0.1, & ! node id 2
-0.1, 1.0, & ! node id 4
1.0, 1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus tot and num conn.
numQuadElems=1
numTriElems=0
numPentElems=0
numMultiElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numMultiElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+7*numMultiElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(numElemConn))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,-0.1, & ! node id 2
2.1,-0.1, & ! node id 3
1.0, 1.0, & ! node id 5
2.1, 1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=2
numPentElems=0
numMultiElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numMultiElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+7*numMultiElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=5
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1,1.0, & ! node id 4
1.0,1.0, & ! node id 5
-0.1,2.1, & ! node id 7
0.5,2.5, & ! node id 8
1.0,2.1 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2, & ! node id 8
2/) ! node id 9
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=0
numPentElems=1
numMultiElems=0
numTotElems=numTriElems+numQuadElems+numPentElems+numMultiElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+7*numMultiElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/5/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,5,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=6
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,9,10,11,12/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.1,1.0, & ! node id 6
1.0,2.1, & ! node id 9
1.5,2.5, & ! node id 10
2.5,2.5, & ! node id 11
2.5,2.1 /) ! node id 12
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 9
3, & ! node id 10
3, & ! node id 11
3/) ! node id 12
! Set the number of each type of element, plus tot and num conn.
numQuadElems=0
numTriElems=0
numPentElems=0
numMultiElems=1
numTotElems=numTriElems+numQuadElems+numPentElems+numMultiElems
numElemConn=3*numTriElems+4*numQuadElems+ &
5*numPentElems+7*numMultiElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/7/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(numElemConn))
elemConn=(/1,2,3,ESMF_MESH_POLYBREAK,6,5,4/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_CART, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Array spec
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create dest. field
dstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. area field
dstAreaField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create exact dest. field
xdstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="xdest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
! Should only be 1 localDE
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
dstFarrayPtr=0.0
! Init exact destination field
! Should only be 1 localDE
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Set exact dest value
iconn=1
do i1=1,numTotElems
! Loop through nodes in elem
! to compute point in center
x=0.0
y=0.0
num_conn=0
do i2=1,elemTypes(i1)
if (elemConn(iconn) .ne. ESMF_MESH_POLYBREAK) then
inode=2*(elemConn(iconn)-1)
x=x+nodeCoords(inode+1)
y=y+nodeCoords(inode+2)
num_conn=num_conn+1
endif
iconn=iconn+1
enddo
x=x*(1.0/REAL(num_conn,ESMF_KIND_R8))
y=y*(1.0/REAL(num_conn,ESMF_KIND_R8))
! Set exact function
xdstFarrayPtr(i1) = 20.0+x+y
enddo
! For now, Easy set interpolated function
!xdstFarrayPtr=1.0
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
#if 0
call ESMF_MeshWrite(srcMesh,"srcMesh")
call ESMF_MeshWrite(dstMesh,"dstMesh")
#endif
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
srcMaskValues=(/1/), &
dstField=dstField, &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
errorTot=0.0
dstmass = 0.
! get dst Field
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstAreaField, 0, dstAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, 0, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1)*fptr(i1)
! Instead do this
dstmass = dstmass + dstAreaptr(i1)*dstFarrayPtr(i1)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1) .lt. 0.999) cycle
! write(*,*) i1,"::",dstFarrayPtr(i1),xdstFarrayPtr(i1)
if (xdstFarrayPtr(i1) .ne. 0.0) then
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
else
error=ABS(dstFarrayPtr(i1) - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
errorTot=errorTot+error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
endif
enddo
srcmass(1) = 0.
! get src pointer
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcAreaField, 0, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, 0, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
srcmass(1) = srcmass(1) + srcFracptr(i1)*srcAreaptr(i1)*srcFarrayPtr(i1)
enddo
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*) "=== Mesh containing a Multipolygon Element ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the meshes
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return success if we've gotten this far
rc=ESMF_SUCCESS
end subroutine test_RegridCsrvCartMultiPoly
subroutine test_regridPerLocStatus(rc)
integer, intent(out) :: rc
logical :: correct
integer :: localrc
type(ESMF_Mesh) :: dstMesh
type(ESMF_Mesh) :: srcMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField, regridStatusField
type(ESMF_Array) :: dstArray
type(ESMF_Array) :: lonArrayA
type(ESMF_Array) :: srcArrayA
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: farrayPtrXC(:,:), farrayPtr1D(:)
real(ESMF_KIND_R8), pointer :: farrayPtrYC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtr(:,:),farrayPtr2(:,:)
integer(ESMF_KIND_I4), pointer :: statusPtr(:)
integer :: clbnd(2),cubnd(2)
integer :: fclbnd(2),fcubnd(2)
integer :: i1,i2,i3, index(2)
integer :: lDE, localDECount
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
real(ESMF_KIND_R8) :: dx,dy
real(ESMF_KIND_R8) :: x,y
integer :: spherical_grid
integer, pointer :: larrayList(:)
integer :: localPet, petCount
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes, numElems
integer :: numQuadElems,numTriElems, numTotElems
! result code
integer :: finalrc
! init success flag
correct=.true.
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
! Setup Src Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1,-0.1, & ! node id 1
1.0,-0.1, & ! node id 2
2.1,-0.1, & ! node id 3
-0.1, 1.0, & ! node id 4
1.0, 1.0, & ! node id 5
2.1, 1.0, & ! node id 6
-0.1, 2.1, & ! node id 7
1.0, 2.1, & ! node id 8
2.1, 2.1 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numQuadElems=3
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the node mask array.
! Mask out elem 5
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 1
0, & ! elem id 2
0, & ! elem id 3
0, & ! elem id 4
1/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1, -0.1, & ! node id 1
1.0, -0.1, & ! node id 2
-0.1, 1.0, & ! node id 4
1.0, 1.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,-0.1, & ! node id 2
2.1,-0.1, & ! node id 3
1.0, 1.0, & ! node id 5
2.1, 1.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numQuadElems=0
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 2
0/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.1,1.0, & ! node id 4
1.0,1.0, & ! node id 5
-0.1,2.1, & ! node id 7
1.0,2.1 /) ! node id 8
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,1.0, & ! node id 5
2.1,1.0, & ! node id 6
1.0,2.1, & ! node id 8
2.1,2.1 /) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/1/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementMask=elemMask, &
elementIds=elemIds, elementTypes=elemTypes, &
elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source field
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
srcField = ESMF_FieldCreate(srcMesh, arrayspec, &
meshLoc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
deallocate(elemMask)
! Create Dest Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.5,-0.5, & ! node id 1 Put outside the src grid
1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
0.0,1.0, & ! node id 4
1.2,1.2, & ! node id 5
2.0,1.1, & ! node id 6
0.0,2.0, & ! node id 7
1.1,2.0, & ! node id 8
2.0,2.0 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numQuadElems=3
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the node mask array.
! Mask out node 9
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 1
0, & ! elem id 2
2, & ! elem id 3
0, & ! elem id 4
0/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.5,-0.5, & ! node id 1 Put outside src grid
1.0, 0.0, & ! node id 2
0.0, 1.0, & ! node id 4
1.2, 1.2 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
1.2,1.2, & ! node id 5
2.0,1.1 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numQuadElems=0
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 2
2/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,1.0, & ! node id 4
1.2,1.2, & ! node id 5
0.0,2.0, & ! node id 7
1.1,2.0 /) ! node id 8
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.2,1.2, & ! node id 5
2.0,1.1, & ! node id 6
1.1,2.0, & ! node id 8
2.0,2.0 /) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementMask=elemMask, &
elementIds=elemIds, elementTypes=elemTypes, &
elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemMask)
deallocate(elemConn)
! Create dest field
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
dstField = ESMF_FieldCreate(dstMesh, arrayspec, &
meshLoc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create regrid status field
regridStatusField=ESMF_FieldCreate(dstMesh, ESMF_TYPEKIND_I4, &
meshLoc=ESMF_MESHLOC_ELEMENT, &
name="regrid status", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
srcMaskValues=(/1/), &
dstField=dstField, &
dstMaskValues=(/2/), &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
dstStatusField=regridStatusField, &
unmappedAction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check destination field
! Should only be 1 localDE
call ESMF_FieldGet(regridStatusField, 0, statusPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! write(*,*) localPet," Status Field=",statusPtr
! Check status
correct=.true.
if (PetCount .eq. 1) then
if (statusPtr(1) .ne. ESMF_REGRIDSTATUS_SMSK_OUT_MP) correct=.false.
if (statusPtr(2) .ne. ESMF_REGRIDSTATUS_SMSK_MP) correct=.false.
if (statusPtr(3) .ne. ESMF_REGRIDSTATUS_DSTMASKED) correct=.false.
if (statusPtr(4) .ne. ESMF_REGRIDSTATUS_SMSK_MP) correct=.false.
if (statusPtr(5) .ne. ESMF_REGRIDSTATUS_SRCMASKED) correct=.false.
else if (petCount .eq. 4) then
if (localPET .eq. 0) then !!! This part only for PET 0
! Check status for elemIds=(/1/)
if (statusPtr(1) .ne. ESMF_REGRIDSTATUS_SMSK_OUT_MP) correct=.false.
else if (localPET .eq. 1) then !!! This part only for PET 1
! Check status for elemIds=(/2,3/)
if (statusPtr(1) .ne. ESMF_REGRIDSTATUS_SMSK_MP) correct=.false.
if (statusPtr(2) .ne. ESMF_REGRIDSTATUS_DSTMASKED) correct=.false.
else if (localPET .eq. 2) then !!! This part only for PET 2
! Check status for elemIds=(/4/)
if (statusPtr(1) .ne. ESMF_REGRIDSTATUS_SMSK_MP) correct=.false.
else if (localPET .eq. 3) then !!! This part only for PET 3
! Check status for elemIds=(/5/)
if (statusPtr(1) .ne. ESMF_REGRIDSTATUS_SRCMASKED) correct=.false.
endif
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(regridStatusField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the Meshes
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flag
if (correct) then
rc=ESMF_SUCCESS
else
rc=ESMF_FAILURE
endif
end subroutine test_regridPerLocStatus
subroutine test_regrid2TileDG(itrp,csrv,rc)
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
logical :: correct
integer :: localrc
type(ESMF_Grid) :: srcGrid
type(ESMF_Grid) :: dstGrid
type(ESMF_Field) :: srcField, errorField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Array) :: dstArray
type(ESMF_Array) :: srcArray
type(ESMF_Field) :: dstFracField
type(ESMF_Field) :: srcFracField
type(ESMF_Field) :: srcArea, dstArea
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
type(ESMF_DistGrid) :: srcDistgrid
type(ESMF_DELayout) :: delayout
integer(ESMF_KIND_I4), pointer :: maskB(:,:), maskA(:,:)
real(ESMF_KIND_R8), pointer :: srcAreaptr(:,:), dstAreaptr(:,:)
real(ESMF_KIND_R8), pointer :: srcFracptr(:,:), dstFracptr(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtrXC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtrYC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtr(:,:), farrayPtr2(:,:)
real(ESMF_KIND_R8), pointer :: xfarrayPtr(:,:)
real(ESMF_KIND_R8), pointer :: fptr(:,:),xfptr(:,:),errorfptr(:,:)
integer :: clbnd(2),cubnd(2)
integer :: fclbnd(2),fcubnd(2)
integer :: i1,i2,i3, index(2)
integer :: lDE, srclocalDECount, dstlocalDECount
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
integer :: src_cntr_nx(2), src_cntr_ny(2)
real(ESMF_KIND_R8) :: src_cnr_minx(2), src_cnr_miny(2)
real(ESMF_KIND_R8) :: src_cnr_maxx(2), src_cnr_maxy(2)
integer :: dst_cntr_nx, dst_cntr_ny
integer :: dst_cnr_nx, dst_cnr_ny
real(ESMF_KIND_R8) :: dst_cnr_minx, dst_cnr_miny
real(ESMF_KIND_R8) :: dst_cnr_maxx, dst_cnr_maxy
integer :: tile
integer :: tile_cnr_nx, tile_cnr_ny
integer :: num_arrays
real(ESMF_KIND_R8) :: tile_cnr_minx, tile_cnr_miny
real(ESMF_KIND_R8) :: tile_cnr_maxx, tile_cnr_maxy
real(ESMF_KIND_R8) :: cnr_x, cnr_y
real(ESMF_KIND_R8) :: cnr_p1_x, cnr_p1_y
real(ESMF_KIND_R8) :: dx,dy
real(ESMF_KIND_R8) :: src_dx, src_dy
real(ESMF_KIND_R8) :: dst_dx, dst_dy
real(ESMF_KIND_R8) :: lon, lat, theta, phi, DEG2RAD
real(ESMF_KIND_R8) :: half_dx, half_dy
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
integer :: spherical_grid
integer :: localPet, petCount
type(ESMF_DistGridConnection) :: connectionList(1)
! type(ESMF_DistGridConnection) :: connectionList(2)
integer :: minIndex(2,2), maxIndex(2,2)
integer :: regDecomp(2,2)
type(ESMF_Decomp_Flag) :: decomp(2,2)
integer :: deCount
integer, allocatable :: localDEtoDEMap(:), deToTileMap(:)
! result code
integer :: finalrc
! init success flag
correct=.true.
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Set src coordinates and resolution
!! Src tile 1
src_cntr_nx(1) = 20
src_cntr_ny(1) = 10
src_cnr_minx(1) = 0.0
src_cnr_miny(1) = 0.0
src_cnr_maxx(1) = 10.0
src_cnr_maxy(1) = 10.0
!! Src tile 2
src_cntr_nx(2) = 20
src_cntr_ny(2) = 10
src_cnr_minx(2) = 10.0
src_cnr_miny(2) = 0.0
src_cnr_maxx(2) = 20.0
src_cnr_maxy(2) = 10.0
! Set dst coordinates and resolution
! dst grid is set so that it fits entirely within src grid
dst_cntr_nx = 20
dst_cntr_ny = 20
dst_cnr_nx = dst_cntr_nx+1
dst_cnr_ny = dst_cntr_ny+1
dst_cnr_minx = 0.5
dst_cnr_miny = 0.5
dst_cnr_maxx = 19.5
dst_cnr_maxy = 9.5
! Create connectionList
! periodicity
call ESMF_DistgridConnectionSet(connection=connectionList(1), &
tileIndexA=1,tileIndexB=2, &
positionVector=(/-src_cntr_nx(1),0/), &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Setup index space
minIndex(:,1)=(/1,1/)
maxIndex(:,1)=(/src_cntr_nx(1),src_cntr_ny(1)/)
regDecomp(:,1)=(/petCount,1/)
minIndex(:,2)=(/1,1/)
maxIndex(:,2)=(/src_cntr_nx(2),src_cntr_ny(2)/)
regDecomp(:,2)=(/petCount,1/)
decomp(:,:)=ESMF_DECOMP_BALANCED
! Create source distgrid
srcDistgrid=ESMF_DistgridCreate(minIndexPTile=minIndex, maxIndexPTile=maxIndex, regDecompPTile=regDecomp, &
decompflagPTile=decomp,indexflag=ESMF_INDEX_GLOBAL, &
connectionList=connectionList, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! setup source grid
srcGrid=ESMF_GridCreate(distgrid=srcDistgrid, indexflag=ESMF_INDEX_GLOBAL, &
coordSys=ESMF_COORDSYS_CART, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! setup dest. grid
dstGrid=ESMF_GridCreateNoPeriDim(minIndex=(/1,1/),maxIndex=(/dst_cntr_nx,dst_cntr_ny/),regDecomp=(/1,petCount/), &
coordSys=ESMF_COORDSYS_CART, indexflag=ESMF_INDEX_GLOBAL, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Create source/destination fields
call ESMF_ArraySpecSet(arrayspec, 2, ESMF_TYPEKIND_R8, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
srcField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
xdstField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="xdest", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
errorField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
srcFracField = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
srcArea = ESMF_FieldCreate(srcGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="source", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstFracField = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
dstArea = ESMF_FieldCreate(dstGrid, arrayspec, &
staggerloc=ESMF_STAGGERLOC_CENTER, name="dest", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Allocate coordinates
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridAddCoord(srcGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CENTER, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridAddCoord(dstGrid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Get arrays
! dstArray
call ESMF_FieldGet(dstField, array=dstArray, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! srcArray
call ESMF_FieldGet(srcField, array=srcArray, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Get information for going from localDE to Tile
call ESMF_GridGet(srcGrid, localDECount=srclocalDECount, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_DistgridGet(srcDistgrid, delayout=delayout, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
allocate(localDEtoDEMap(srclocalDECount))
call ESMF_DELayoutGet(delayout, deCount=deCount, localDeToDeMap=localDeToDEMap, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
allocate(deToTileMap(deCount))
call ESMF_DistgridGet(srcDistgrid, deToTileMap=detoTileMap, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Construct Src Grid
!!!! CORNERS !!!!
do lDE=0,srclocalDECount-1
!! get coord 1
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
!! Get Tile from localDE
tile=deToTileMap(localDEtoDEMap(lDE+1)+1)
!! Set values based on tile
tile_cnr_nx=src_cntr_nx(tile)+1 ! corners are 1 bigger than centers
tile_cnr_ny=src_cntr_ny(tile)+1 ! corners are 1 bigger than centers
tile_cnr_minx=src_cnr_minx(tile)
tile_cnr_maxx=src_cnr_maxx(tile)
tile_cnr_miny=src_cnr_miny(tile)
tile_cnr_maxy=src_cnr_maxy(tile)
! write(*,*) "t=",tile," cnr bnds l=",clbnd(1),clbnd(2)," u=",cubnd(1),cubnd(2)
! write(*,*) "t=",tile," nx=",tile_cnr_nx," ny=",tile_cnr_ny
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! Set source coordinates
farrayPtrXC(i1,i2) = ((tile_cnr_maxx-tile_cnr_minx)*REAL(i1-1)/REAL(tile_cnr_nx-1))+tile_cnr_minx
farrayPtrYC(i1,i2) = ((tile_cnr_maxy-tile_cnr_miny)*REAL(i2-1)/REAL(tile_cnr_ny-1))+tile_cnr_miny
enddo
enddo
enddo ! lDE
! Construct Src Grid
!!!! CENTERS !!!!
do lDE=0,srclocalDECount-1
!! get coord 1
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridGetCoord(srcGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! get src pointer
call ESMF_FieldGet(srcField, lDE, farrayPtr, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
!! Get Tile from localDE
tile=deToTileMap(localDEtoDEMap(lDE+1)+1)
!! Set values based on tile
tile_cnr_nx=src_cntr_nx(tile)+1 ! corners 1 bigger than center
tile_cnr_ny=src_cntr_ny(tile)+1 ! corners 1 bigger than center
tile_cnr_minx=src_cnr_minx(tile)
tile_cnr_maxx=src_cnr_maxx(tile)
tile_cnr_miny=src_cnr_miny(tile)
tile_cnr_maxy=src_cnr_maxy(tile)
!! set coords, interpolated function
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! corner coordinate
cnr_x = ((tile_cnr_maxx-tile_cnr_minx)*REAL(i1-1)/REAL(tile_cnr_nx-1))+tile_cnr_minx
cnr_y = ((tile_cnr_maxy-tile_cnr_miny)*REAL(i2-1)/REAL(tile_cnr_ny-1))+tile_cnr_miny
! corner +1 coordinate
cnr_p1_x = ((tile_cnr_maxx-tile_cnr_minx)*REAL(i1+1-1)/REAL(tile_cnr_nx-1))+tile_cnr_minx
cnr_p1_y = ((tile_cnr_maxy-tile_cnr_miny)*REAL(i2+1-1)/REAL(tile_cnr_ny-1))+tile_cnr_miny
! Set source coordinates
farrayPtrXC(i1,i2) = 0.5*(cnr_x+cnr_p1_x)
farrayPtrYC(i1,i2) = 0.5*(cnr_y+cnr_p1_y)
! set src data
farrayPtr(i1,i2) = farrayPtrXC(i1,i2) + farrayPtrYC(i1,i2) + 20.0
enddo
enddo
enddo ! lDE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Destination grid
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Get number of local DEs
call ESMF_GridGet(dstGrid, localDECount=dstlocalDECount, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Get memory and set coords for dst
!! CORNERS !!
do lDE=0,dstlocalDECount-1
!! get coords
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CORNER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! write(*,*) "D: cnr bnds l=",clbnd(1),clbnd(2)," u=",cubnd(1),cubnd(2), " dcn=",dst_cnr_nx,dst_cnr_ny
!! set coords
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! set source coordinates
farrayPtrXC(i1,i2) = ((dst_cnr_maxx-dst_cnr_minx)*REAL(i1-1)/REAL(dst_cnr_nx-1))+dst_cnr_minx
farrayPtrYC(i1,i2) = ((dst_cnr_maxy-dst_cnr_miny)*REAL(i2-1)/REAL(dst_cnr_ny-1))+dst_cnr_miny
enddo
enddo
enddo ! lDE
! Get memory and set coords for dst
!! CENTERS
do lDE=0,dstlocalDECount-1
!! get coords
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=1, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrXC, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridGetCoord(dstGrid, localDE=lDE, staggerLoc=ESMF_STAGGERLOC_CENTER, coordDim=2, &
computationalLBound=clbnd, computationalUBound=cubnd, farrayPtr=farrayPtrYC, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldGet(dstField, lDE, farrayPtr, computationalLBound=fclbnd, &
computationalUBound=fcubnd, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldGet(xdstField, lDE, xfarrayPtr, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
!! set coords
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! corner coordinate
cnr_x = ((dst_cnr_maxx-dst_cnr_minx)*REAL(i1-1)/REAL(dst_cnr_nx-1))+dst_cnr_minx
cnr_y = ((dst_cnr_maxy-dst_cnr_miny)*REAL(i2-1)/REAL(dst_cnr_ny-1))+dst_cnr_miny
! corner coordinate
cnr_p1_x = ((dst_cnr_maxx-dst_cnr_minx)*REAL(i1+1-1)/REAL(dst_cnr_nx-1))+dst_cnr_minx
cnr_p1_y = ((dst_cnr_maxy-dst_cnr_miny)*REAL(i2+1-1)/REAL(dst_cnr_ny-1))+dst_cnr_miny
! Set destination center coordinates
farrayPtrXC(i1,i2) = 0.5*(cnr_x+cnr_p1_x)
farrayPtrYC(i1,i2) = 0.5*(cnr_y+cnr_p1_y)
! set expected result field
xfarrayPtr(i1,i2) = farrayPtrXC(i1,i2) + farrayPtrYC(i1,i2) + 20.0
! initialize destination field
farrayPtr(i1,i2)=0.0
enddo
enddo
enddo ! lDE
#if 0
call ESMF_GridWriteVTK(srcGrid,staggerloc=ESMF_STAGGERLOC_CENTER, &
filename="srcGrid", &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridWriteVTK(srcGrid,staggerloc=ESMF_STAGGERLOC_CORNER, &
filename="srcGridCnr", &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridWriteVTK(dstGrid,staggerloc=ESMF_STAGGERLOC_CENTER, &
filename="dstGrid", &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridWriteVTK(dstGrid,staggerloc=ESMF_STAGGERLOC_CORNER, &
filename="dstGridCnr", &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
#endif
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
dstField=dstField, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
normType=ESMF_NORMTYPE_FRACAREA, &
routeHandle=routeHandle, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Get the integration weights
call ESMF_FieldRegridGetArea(srcArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstArea, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
dstmass = 0.
! Check if the values are close
do lDE=0,dstLocalDECount-1
! get dst Field
call ESMF_FieldGet(dstField, lDE, fptr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, lDE, xfptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get error Field
call ESMF_FieldGet(errorField, lDE, errorfptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstArea, lDE, dstAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, lDE, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
! This is WRONG, shouldn't include Frac
dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1,i2)*fptr(i1,i2)
! If this destination cell isn't covered by a sig. amount of source, then compute error on it.
! (Note that this is what SCRIP does)
if (dstFracptr(i1,i2) .lt. 0.999) cycle
if (xfptr(i1,i2) .ne. 0.0) then
errorfptr(i1,i2)=ABS(fptr(i1,i2) - xfptr(i1,i2))/ABS(xfptr(i1,i2))
error = error + errorfptr(i1,i2)
if (errorfptr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfptr(i1,i2)
endif
if (errorfptr(i1,i2) < minerror(1)) then
minerror(1) = errorfptr(i1,i2)
endif
else
errorfptr(i1,i2)=ABS(fptr(i1,i2) - xfptr(i1,i2))
error = error + errorfptr(i1,i2)
if (errorfptr(i1,i2) > maxerror(1)) then
maxerror(1) = errorfptr(i1,i2)
endif
if (errorfptr(i1,i2) < minerror(1)) then
minerror(1) = errorfptr(i1,i2)
endif
endif
enddo
enddo
enddo ! lDE
srcmass(1) = 0.
do lDE=0,srcLocalDECount-1
! get src pointer
call ESMF_FieldGet(srcField, lDE, fptr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcArea, lDE, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, lDE, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
do i2=clbnd(2),cubnd(2)
srcmass(1) = srcmass(1) + srcFracptr(i1,i2)*srcAreaptr(i1,i2)*fptr(i1,i2)
enddo
enddo
enddo ! lDE
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Output results
if (localPet == 0) then
write(*,*) "=== 2 Tile ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", (maxerrorg(1) + minerrorg(1))/2
write(*,*) " "
endif
#if 0
call ESMF_GridWriteVTK(srcGrid,staggerloc=ESMF_STAGGERLOC_CENTER, &
filename="srcGridT", array1=srcArray, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridWriteVTK(dstGrid,staggerloc=ESMF_STAGGERLOC_CENTER, &
filename="dstGridT", array1=dstArray, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
#endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(errorField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstArea, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the grids
call ESMF_GridDestroy(srcGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the srcDistgrid
call ESMF_DistgridDestroy(srcDistgrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_GridDestroy(dstGrid, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flag
if (correct) then
rc=ESMF_SUCCESS
else
rc=ESMF_FAILURE
endif
end subroutine test_regrid2TileDG
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Creates the following mesh on
! 1 or 4 PETs. Returns an error
! if run on other than 1 or 4 PETs
!
! Mesh Ids
!
! 3.0 * ------------ * ------------- *
! | | / |
! 2.5 | | 10 / |
! | 7 | / |
! 2.0 | | / 9 |
! | | / |
! 1.5 * ------------ * ------------- *
! | | |
! 1.0 | | |
! | 1 | 3 |
! 0.5 | | |
! | | |
! 0.0 * ------------ * -------------- *
!
! 0.0 0.5 1.0 1.5 2.0 2.5 3.0
!
! Node Ids at corners
! Element Ids in centers
!
!!!!!
!
! The owners for 1 PET are all Pet 0.
! The owners for 4 PETs are as follows:
!
! Mesh Owners
!
! 3.0 * ------------ * ------------- *
! | | / |
! 2.5 | | 2 / |
! | 2 | / |
! 2.0 | | / 2 |
! | | / |
! 1.5 * ------------ * ------------- *
! | | |
! 1.0 | | |
! | 0 | 1 |
! 0.5 | | |
! | | |
! 0.0 * ------------ * -------------- *
!
! 0.0 0.5 1.0 1.5 2.0 2.5 3.0
!
! Element Owners in centers
!
subroutine CreateTestMesh2x2EE(mesh, rc)
type(ESMF_Mesh), intent(out) :: mesh
integer :: rc
integer :: numElems,numOwnedElemsTst
integer :: numElemCorners, numTriElems, numQuadElems
real(ESMF_KIND_R8), pointer :: elemCoords(:,:)
real(ESMF_KIND_R8), pointer :: elemCornerCoords(:,:)
integer, pointer :: elemIds(:),elemTypes(:)
integer :: petCount, localPet
type(ESMF_VM) :: vm
! get global VM
call ESMF_VMGetGlobal(vm, rc=rc)
if (rc /= ESMF_SUCCESS) return
call ESMF_VMGet(vm, localPet=localPet, petCount=petCount, rc=rc)
if (rc /= ESMF_SUCCESS) return
! return with an error if not 1 or 4 PETs
if ((petCount /= 1) .and. (petCount /=4)) then
rc=ESMF_FAILURE
return
endif
! Setup mesh info depending on the
! number of PETs
if (petCount .eq. 1) then
! Fill in elem data
numTriElems=2
numQuadElems=3
numElems=numTriElems+numQuadElems
numElemCorners=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/1,3,7,9,10/)
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! 1
ESMF_MESHELEMTYPE_QUAD, & ! 3
ESMF_MESHELEMTYPE_QUAD, & ! 7
ESMF_MESHELEMTYPE_TRI, & ! 9
ESMF_MESHELEMTYPE_TRI/) ! 10
!! elem coords
allocate(elemCoords(2,numElems))
elemCoords(:,1)=(/0.75,0.75/) ! 1
elemCoords(:,2)=(/2.25,0.75/) ! 3
elemCoords(:,3)=(/0.75,2.25/) ! 7
elemCoords(:,4)=(/2.50,2.00/) ! 9
elemCoords(:,5)=(/2.00,2.50/) ! 10
!! elem corner Coords
allocate(elemCornerCoords(2,numElemCorners))
elemCornerCoords(:,1)=(/0.0,0.0/) ! 1
elemCornerCoords(:,2)=(/1.5,0.0/) ! 1
elemCornerCoords(:,3)=(/1.5,1.5/) ! 1
elemCornerCoords(:,4)=(/0.0,1.5/) ! 1
elemCornerCoords(:,5)=(/1.5,0.0/) ! 3
elemCornerCoords(:,6)=(/3.0,0.0/) ! 3
elemCornerCoords(:,7)=(/3.0,1.5/) ! 3
elemCornerCoords(:,8)=(/1.5,1.5/) ! 3
elemCornerCoords(:,9)=(/0.0,1.5/) ! 7
elemCornerCoords(:,10)=(/1.5,1.5/) ! 7
elemCornerCoords(:,11)=(/1.5,3.0/) ! 7
elemCornerCoords(:,12)=(/0.0,3.0/) ! 7
elemCornerCoords(:,13)=(/1.5,1.5/) ! 9
elemCornerCoords(:,14)=(/3.0,1.5/) ! 9
elemCornerCoords(:,15)=(/3.0,3.0/) ! 9
elemCornerCoords(:,16)=(/1.5,1.5/) ! 10
elemCornerCoords(:,17)=(/3.0,3.0/) ! 10
elemCornerCoords(:,18)=(/1.5,3.0 /) ! 10
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPet .eq. 0) then
! Fill in elem data
numTriElems=0
numQuadElems=1
numElems=numTriElems+numQuadElems
numElemCorners=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/1/)
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! 1
!! elem coords
allocate(elemCoords(2,numElems))
elemCoords(:,1)=(/0.75,0.75/) ! 1
!! elem corner Coords
allocate(elemCornerCoords(2,numElemCorners))
elemCornerCoords(:,1)=(/0.0,0.0/) ! 1
elemCornerCoords(:,2)=(/1.5,0.0/) ! 1
elemCornerCoords(:,3)=(/1.5,1.5/) ! 1
elemCornerCoords(:,4)=(/0.0,1.5/) ! 1
else if (localPet .eq. 1) then
! Fill in elem data
numTriElems=0
numQuadElems=1
numElems=numTriElems+numQuadElems
numElemCorners=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/3/)
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! 3
!! elem coords
allocate(elemCoords(2,numElems))
elemCoords(:,1)=(/2.25,0.75/) ! 3
!! elem corner Coords
allocate(elemCornerCoords(2,numElemCorners))
elemCornerCoords(:,1)=(/1.5,0.0/) ! 3
elemCornerCoords(:,2)=(/3.0,0.0/) ! 3
elemCornerCoords(:,3)=(/3.0,1.5/) ! 3
elemCornerCoords(:,4)=(/1.5,1.5/) ! 3
else if (localPet .eq. 2) then
! Fill in elem data
numTriElems=2
numQuadElems=1
numElems=numTriElems+numQuadElems
numElemCorners=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/7,9,10/)
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! 7
ESMF_MESHELEMTYPE_TRI, & ! 9
ESMF_MESHELEMTYPE_TRI/) ! 10
!! elem coords
allocate(elemCoords(2,numElems))
elemCoords(:,1)=(/0.75,2.25/) ! 7
elemCoords(:,2)=(/2.50,2.00/) ! 9
elemCoords(:,3)=(/2.00,2.50/) ! 10
!! elem corner Coords
allocate(elemCornerCoords(2,numElemCorners))
elemCornerCoords(:,1)=(/0.0,1.5/) ! 7
elemCornerCoords(:,2)=(/1.5,1.5/) ! 7
elemCornerCoords(:,3)=(/1.5,3.0/) ! 7
elemCornerCoords(:,4)=(/0.0,3.0/) ! 7
elemCornerCoords(:,5)=(/1.5,1.5/) ! 9
elemCornerCoords(:,6)=(/3.0,1.5/) ! 9
elemCornerCoords(:,7)=(/3.0,3.0/) ! 9
elemCornerCoords(:,8)=(/1.5,1.5/) ! 10
elemCornerCoords(:,9)=(/3.0,3.0/) ! 10
elemCornerCoords(:,10)=(/1.5,3.0 /) ! 10
else if (localPet .eq. 3) then
! Fill in elem data
numTriElems=0
numQuadElems=0
numElems=numTriElems+numQuadElems
numElemCorners=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
!! elem types
allocate(elemTypes(numElems))
!! elem coords
allocate(elemCoords(2,numElems))
!! elem corner Coords
allocate(elemCornerCoords(2,numElemCorners))
endif
endif
! Create Mesh structure in 1 step
mesh=ESMF_MeshCreate(parametricDim=2, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
elementIds=elemIds,&
elementTypes=elemTypes,&
elementCoords=elemCoords,&
elementCornerCoords=elemCornerCoords, &
rc=rc)
if (rc /= ESMF_SUCCESS) return
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemCoords)
deallocate(elemCornerCoords)
! Output Mesh for debugging
!call ESMF_MeshWrite(mesh,"meshee",rc=localrc)
!if (localrc .ne. ESMF_SUCCESS) rc=ESMF_FAILURE
! Return success
rc=ESMF_SUCCESS
end subroutine CreateTestMesh2x2EE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Creates the following mesh on
! 1 or 2 PETs. Returns an error
! if run on other than 1 or 2 PETs
!
! Mesh Ids
!
! 3.0 7 ------------ 8 ------------- 9
! | | / |
! 2.5 | | 10 / |
! | 7 | / |
! 2.0 | | / 9 |
! | | / |
! 1.5 4 ------------ 5 ------------- 6
! | | |
! 1.0 | | |
! | 1 | 3 |
! 0.5 | | |
! | | |
! 0.0 1 ------------ 2 -------------- 3
!
! 0.0 0.5 1.0 1.5 2.0 2.5 3.0
!
! Node Ids at corners
! Element Ids in centers
!
!!!!!
!
! The owners for 1 PET are all Pet 0.
! The owners for 2 PETs are as follows:
!
! Mesh Owners
!
! 3.0 2 ------------ 2 ------------- 2
! | | / |
! 2.5 | | 2 / |
! | 2 | / |
! 2.0 | | / 2 |
! | | / |
! 1.5 0 ------------ 0 ------------- 1
! | | |
! 1.0 | | |
! | 0 | 1 |
! 0.5 | | |
! | | |
! 0.0 0 ------------ 0 -------------- 1
!
! 0.0 0.5 1.0 1.5 2.0 2.5 3.0
!
! Element Owners in centers
!
subroutine CreateTestMesh2x2(mesh, rc)
type(ESMF_Mesh), intent(out) :: mesh
integer :: rc
integer :: petCount, localPet
type(ESMF_VM) :: vm
integer :: numNodes, numElems, numTriElems, numQuadElems
integer :: numElemCorners
integer, allocatable :: nodeIds(:)
real(ESMF_KIND_R8), allocatable :: nodeCoords(:)
integer, allocatable :: nodeOwners(:)
integer, allocatable :: elemIds(:)
integer, allocatable :: elemTypes(:)
integer, allocatable :: elemConn(:)
real(ESMF_KIND_R8), pointer :: elemCoords(:)
! get global VM
call ESMF_VMGetGlobal(vm, rc=rc)
if (rc /= ESMF_SUCCESS) return
call ESMF_VMGet(vm, localPet=localPet, petCount=petCount, rc=rc)
if (rc /= ESMF_SUCCESS) return
! return with an error if not 1 or 4 PETs
if ((petCount /= 1) .and. (petCount /=4)) then
rc=ESMF_FAILURE
return
endif
! Setup mesh info depending on the
! number of PETs
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.5,0.0, & ! node id 2
3.0,0.0, & ! node id 3
0.0,1.5, & ! node id 4
1.5,1.5, & ! node id 5
3.0,1.5, & ! node id 6
0.0,3.0, & ! node id 7
1.5,3.0, & ! node id 8
3.0,3.0 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Fill in elem data
numTriElems=2
numQuadElems=3
numElems=numTriElems+numQuadElems
numElemCorners=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/1,3,7,9,10/)
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! 1
ESMF_MESHELEMTYPE_QUAD, & ! 3
ESMF_MESHELEMTYPE_QUAD, & ! 7
ESMF_MESHELEMTYPE_TRI, & ! 9
ESMF_MESHELEMTYPE_TRI/) ! 10
!! elem coords
allocate(elemCoords(2*numElems))
elemCoords=(/0.75,0.75, & ! 1
2.25,0.75, & ! 3
0.75,2.25, & ! 7
2.50,2.00, & ! 9
2.00,2.50/) ! 10
!! elem corner Coords
allocate(elemConn(numElemCorners))
elemConn=(/1,2,5,4, & ! 1
2,3,6,5, & ! 3
4,5,8,7, & ! 7
5,6,9, & ! 9
5,9,8/) ! 10
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPet .eq. 0) then
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,0.0, & ! node id 1
1.5,0.0, & ! node id 2
0.0,1.5, & ! node id 4
1.5,1.5/) ! node id 5
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Fill in elem data
numTriElems=0
numQuadElems=1
numElems=numTriElems+numQuadElems
numElemCorners=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/1/)
!! elem coords
allocate(elemCoords(2*numElems))
elemCoords=(/0.75,0.75/) ! 1
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! 1
!! elem corner Coords
allocate(elemConn(numElemCorners))
elemConn=(/1,2,4,3/) ! 1
else if (localPet .eq. 1) then
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.5,0.0, & ! node id 2
3.0,0.0, & ! node id 3
1.5,1.5, & ! node id 5
3.0,1.5/) ! node id 6
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! 2
1, & ! 3
0, & ! 5
1/) ! 6
! Fill in elem data
numTriElems=0
numQuadElems=1
numElems=numTriElems+numQuadElems
numElemCorners=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/3/)
!! elem coords
allocate(elemCoords(2*numElems))
elemCoords=(/2.25,0.75/) ! 3
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! 3
!! elem corner Coords
allocate(elemConn(numElemCorners))
elemConn=(/1,2,4,3/) ! 3
else if (localPet .eq. 2) then
! Set number of nodes
numNodes=6
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/ &
0.0,1.5, & ! node id 4
1.5,1.5, & ! node id 5
3.0,1.5, & ! node id 6
0.0,3.0, & ! node id 7
1.5,3.0, & ! node id 8
3.0,3.0 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=(/ 0, & ! 4
0, & ! 5
1, & ! 6
2, & ! 7
2, & ! 8
2/) ! 9
! Fill in elem data
numTriElems=2
numQuadElems=1
numElems=numTriElems+numQuadElems
numElemCorners=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/7,9,10/)
!! elem coords
allocate(elemCoords(2*numElems))
elemCoords=(/0.75,2.25, & ! 7
2.50,2.00, & ! 9
2.00,2.50/) ! 10
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! 7
ESMF_MESHELEMTYPE_TRI, & ! 9
ESMF_MESHELEMTYPE_TRI/) ! 10
!! elem corner Coords
allocate(elemConn(numElemCorners))
elemConn=(/1,2,5,4, & ! 7
2,3,6, & ! 9
2,6,5/) ! 10
else if (localPet .eq. 3) then
! Set number of nodes
numNodes=0
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
! Fill in elem data
numTriElems=0
numQuadElems=0
numElems=numTriElems+numQuadElems
numElemCorners=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
!! elem coords
allocate(elemCoords(2*numElems))
!! elem types
allocate(elemTypes(numElems))
!! elem corner Coords
allocate(elemConn(numElemCorners))
endif
endif
! Create Mesh structure in 1 step
mesh=ESMF_MeshCreate(parametricDim=2, spatialDim=2, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
elementCoords=elemCoords, &
rc=rc)
if (rc /= ESMF_SUCCESS) return
! After the creation we are through with the arrays, so they may be
! deallocated.
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
deallocate(elemCoords)
! Output Mesh for debugging
!call ESMF_MeshWrite(mesh,"mesh1",rc=rc)
!if (rc /= ESMF_SUCCESS) return
! Return success
rc=ESMF_SUCCESS
end subroutine CreateTestMesh2x2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Creates the following mesh on
! 1 or 4 PETs. Returns an error
! if run on other than 1 or 4 PETs
!
! Mesh Ids
!
! 3.0 13 ------ 14 ------- 15 ------- 16
! | | | 10 / |
! 2.5 | 7 | 8 | / |
! | | | / 9 |
! 2.0 9 ------- 10 ------- 11 ------- 12
! | | | |
! 1.5 | 4 | 5 | 6 |
! | | | |
! 1.0 5 ------- 6 -------- 7 -------- 8
! | | | |
! 0.5 | 1 | 2 | 3 |
! | | | |
! 0.0 1 ------- 2 -------- 3 -------- 4
!
! 0.0 0.5 1.0 1.5 2.0 2.5 3.0
!
! Node Ids at corners
! Element Ids in centers
!
!!!!!
!
! The owners for 1 PET are all Pet 0.
! The owners for 4 PETs are as follows:
!
! Mesh Owners
!
! 3.0 2 ------- 2 -------- 3 -------- 3
! | | | 3 / |
! | 2 | 2 | / |
! | | | / 3 |
! 2.0 2 ------- 2 -------- 3 -------- 3
! | | | |
! | 2 | 2 | 3 |
! | | | |
! 1.0 0 ------- 0 -------- 1 -------- 1
! | | | |
! | 0 | 1 | 1 |
! | | | |
! 0.0 0 ------- 0 -------- 1 -------- 1
!
! 0.0 1.0 2.0 3.0
!
! Node Owners at corners
! Element Owners in centers
!
subroutine createTestMesh3x3(mesh, rc)
type(ESMF_Mesh), intent(out) :: mesh
integer :: rc
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
real(ESMF_KIND_R8), pointer :: ownedNodeCoords(:)
integer :: numNodes, numOwnedNodes, numOwnedNodesTst
integer :: numElems,numOwnedElemsTst
integer :: numElemConns, numTriElems, numQuadElems
real(ESMF_KIND_R8), pointer :: elemCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:)
integer, pointer :: elemMask(:)
integer :: petCount, localPet
type(ESMF_VM) :: vm
! get global VM
call ESMF_VMGetGlobal(vm, rc=rc)
if (rc /= ESMF_SUCCESS) return
call ESMF_VMGet(vm, localPet=localPet, petCount=petCount, rc=rc)
if (rc /= ESMF_SUCCESS) return
! return with an error if not 1 or 4 PETs
if ((petCount /= 1) .and. (petCount /=4)) then
rc=ESMF_FAILURE
return
endif
! Setup mesh info depending on the
! number of PETs
if (petCount .eq. 1) then
! Fill in node data
numNodes=16
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8, &
9,10,11,12,13,14,&
15,16/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, & ! 1
1.0,0.0, & ! 2
2.0,0.0, & ! 3
3.0,0.0, & ! 4
0.0,1.0, & ! 5
1.0,1.0, & ! 6
2.0,1.0, & ! 7
3.0,1.0, & ! 8
0.0,2.0, & ! 9
1.0,2.0, & ! 10
2.0,2.0, & ! 11
3.0,2.0, & ! 12
0.0,3.0, & ! 13
1.0,3.0, & ! 14
2.0,3.0, & ! 15
3.0,3.0 /) ! 16
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on proc 0
! Fill in elem data
numTriElems=2
numQuadElems=8
numElems=numTriElems+numQuadElems
numElemConns=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/1,2,3,4,5,6,7,8,9,10/)
!! elem mask
allocate(elemMask(numElems))
elemMask=(/0,0,1,0,0,0,0,0,0,0/)
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! 1
ESMF_MESHELEMTYPE_QUAD, & ! 2
ESMF_MESHELEMTYPE_QUAD, & ! 3
ESMF_MESHELEMTYPE_QUAD, & ! 4
ESMF_MESHELEMTYPE_QUAD, & ! 5
ESMF_MESHELEMTYPE_QUAD, & ! 6
ESMF_MESHELEMTYPE_QUAD, & ! 7
ESMF_MESHELEMTYPE_QUAD, & ! 8
ESMF_MESHELEMTYPE_TRI, & ! 9
ESMF_MESHELEMTYPE_TRI/) ! 10
!! elem coords
allocate(elemCoords(2*numElems))
elemCoords=(/0.5,0.5, & ! 1
1.5,0.5, & ! 2
2.5,0.5, & ! 3
0.5,1.5, & ! 4
1.5,1.5, & ! 5
2.5,1.5, & ! 6
0.5,2.5, & ! 7
1.5,2.5, & ! 8
2.75,2.25,& ! 9
2.25,2.75/) ! 10
!! elem conn
allocate(elemConn(numElemConns))
elemConn=(/1,2,6,5, & ! 1
2,3,7,6, & ! 2
3,4,8,7, & ! 3
5,6,10,9, & ! 4
6,7,11,10, & ! 5
7,8,12,11, & ! 6
9,10,14,13, & ! 7
10,11,15,14, & ! 8
11,12,16, & ! 9
11,16,15/) ! 10
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPet .eq. 0) then
! Fill in node data
numNodes=4
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/1,2,5,6/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,0.0, & ! 1
1.0,0.0, & ! 2
0.0,1.0, & ! 5
1.0,1.0 /) ! 6
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on proc 0
! Fill in elem data
numTriElems=0
numQuadElems=1
numElems=numTriElems+numQuadElems
numElemConns=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/1/)
!! elem mask
allocate(elemMask(numElems))
elemMask=(/0/)
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! 1
!! elem coords
allocate(elemCoords(2*numElems))
elemCoords=(/0.5,0.5/) ! 1
!! elem conn
allocate(elemConn(numElemConns))
elemConn=(/1,2,4,3/) ! 1
else if (localPet .eq. 1) then
! Fill in node data
numNodes=6
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/2,3,4,6,7,8/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/1.0,0.0, & ! 2
2.0,0.0, & ! 3
3.0,0.0, & ! 4
1.0,1.0, & ! 6
2.0,1.0, & ! 7
3.0,1.0 /) ! 8
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! 2
1, & ! 3
1, & ! 4
0, & ! 6
1, & ! 7
1/) ! 8
! Fill in elem data
numTriElems=0
numQuadElems=2
numElems=numTriElems+numQuadElems
numElemConns=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/2,3/)
!! elem mask
allocate(elemMask(numElems))
elemMask=(/0,1/)
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! 2
ESMF_MESHELEMTYPE_QUAD/) ! 3
!! elem coords
allocate(elemCoords(2*numElems))
elemCoords=(/1.5,0.5, & ! 2
2.5,0.5/) ! 3
!! elem conn
allocate(elemConn(numElemConns))
elemConn=(/1,2,5,4, & ! 2
2,3,6,5/) ! 3
else if (localPet .eq. 2) then
! Fill in node data
numNodes=9
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/5,6,7, &
9,10,11, &
13,14,15/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/0.0,1.0, & ! 5
1.0,1.0, & ! 6
2.0,1.0, & ! 7
0.0,2.0, & ! 9
1.0,2.0, & ! 10
2.0,2.0, & ! 11
0.0,3.0, & ! 13
1.0,3.0, & ! 14
2.0,3.0/) ! 15
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! 5
0, & ! 6
1, & ! 7
2, & ! 9
2, & ! 10
3, & ! 11
2, & ! 13
2, & ! 14
3/) ! 15
! Fill in elem data
numTriElems=0
numQuadElems=4
numElems=numTriElems+numQuadElems
numElemConns=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/4,5,7,8/)
!! elem mask
allocate(elemMask(numElems))
elemMask=(/0,0,0,0/)
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! 4
ESMF_MESHELEMTYPE_QUAD, & ! 5
ESMF_MESHELEMTYPE_QUAD, & ! 7
ESMF_MESHELEMTYPE_QUAD/) ! 8
!! elem coords
allocate(elemCoords(2*numElems))
elemCoords=(/0.5,1.5, & ! 4
1.5,1.5, & ! 5
0.5,2.5, & ! 7
1.5,2.5/) ! 8
!! elem conn
allocate(elemConn(numElemConns))
elemConn=(/1,2,5,4, & ! 4
2,3,6,5, & ! 5
4,5,8,7, & ! 7
5,6,9,8/) ! 8
else if (localPet .eq. 3) then
! Fill in node data
numNodes=6
!! node ids
allocate(nodeIds(numNodes))
nodeIds=(/7,8,11,12,15,16/)
!! node Coords
allocate(nodeCoords(numNodes*2))
nodeCoords=(/2.0,1.0, & ! 7
3.0,1.0, & ! 8
2.0,2.0, & ! 11
3.0,2.0, & ! 12
2.0,3.0, & ! 15
3.0,3.0 /) ! 16
!! node owners
allocate(nodeOwners(numNodes))
nodeOwners=(/1, & ! 7
1, & ! 8
3, & ! 11
3, & ! 12
3, & ! 15
3/) ! 16
! Fill in elem data
numTriElems=2
numQuadElems=1
numElems=numTriElems+numQuadElems
numElemConns=3*numTriElems+4*numQuadElems
!! elem ids
allocate(elemIds(numElems))
elemIds=(/6,9,10/)
!! elem mask
allocate(elemMask(numElems))
elemMask=(/0,0,0/)
!! elem types
allocate(elemTypes(numElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! 6
ESMF_MESHELEMTYPE_TRI, & ! 9
ESMF_MESHELEMTYPE_TRI/) ! 10
!! elem coords
allocate(elemCoords(2*numElems))
elemCoords=(/2.5,1.5, & ! 6
2.75,2.25,& ! 9
2.25,2.75/) ! 10
!! elem conn
allocate(elemConn(numElemConns))
elemConn=(/1,2,4,3, & ! 6
3,4,6, & ! 9
3,6,5/) ! 10
endif
endif
! Create Mesh structure in 1 step
mesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
coordSys=ESMF_COORDSYS_SPH_DEG, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementIds=elemIds,&
elementTypes=elemTypes, elementConn=elemConn, &
elementCoords=elemCoords, elementMask=elemMask,&
rc=rc)
if (rc /= ESMF_SUCCESS) return
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemCoords)
deallocate(elemConn)
end subroutine createTestMesh3x3
subroutine test_MeshEasyElems(itrp, csrv, rc)
#undef ESMF_METHOD
#define ESMF_METHOD "test_MeshEasyElems"
logical, intent(out) :: itrp
logical, intent(out) :: csrv
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Mesh) :: srcMesh
type(ESMF_Mesh) :: dstMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Field) :: xdstField
type(ESMF_Field) :: srcAreaField, dstAreaField
type(ESMF_Field) :: srcFracField, dstFracField
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_VM) :: vm
real(ESMF_KIND_R8), pointer :: srcFarrayPtr(:), dstFarrayPtr(:), xdstFarrayPtr(:)
real(ESMF_KIND_R8), pointer :: srcAreaPtr(:), dstAreaPtr(:)
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
integer :: i1,i2,i3
real(ESMF_KIND_R8) :: x,y,z
real(ESMF_KIND_R8) :: lat, lon, phi, theta
real(ESMF_KIND_R8),parameter :: &
DEG2RAD = 3.141592653589793_ESMF_KIND_R8/180.0_ESMF_KIND_R8
integer :: localPet, petCount
real(ESMF_KIND_R8) :: srcmass(1), dstmass(1), srcmassg(1), dstmassg(1)
real(ESMF_KIND_R8) :: maxerror(1), minerror(1), error
real(ESMF_KIND_R8) :: maxerrorg(1), minerrorg(1), errorg
real(ESMF_KIND_R8) :: errorTot, errorTotG, dstVal
integer :: num_errorTot
real(ESMF_KIND_R8) :: l_errorTot(1),g_errorTot(1)
integer :: l_num_errorTot(1), g_num_errorTot(1)
integer :: numOwnedElems
real(ESMF_KIND_R8), pointer :: ownedElemCoords(:)
! result code
integer :: finalrc
! Init to success
rc=ESMF_SUCCESS
itrp=.true.
csrv=.true.
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
rc=ESMF_SUCCESS
return
endif
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!! Setup Source !!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Create Source Mesh
call CreateTestMesh2x2EE(srcMesh, rc=localrc) ! Easy Elems Create
! call CreateTestMesh2x2(srcMesh, rc=localrc) ! Non-easy elems create
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Array spec for fields
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create source field
srcField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source area field
srcAreaField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Load test data into the source Field
! Should only be 1 localDE
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Set interpolated function
call ESMF_MeshGet(srcMesh, numOwnedElements=numOwnedElems, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Allocate space for coordinates
allocate(ownedElemCoords(2*numOwnedElems))
! Set interpolated function
call ESMF_MeshGet(srcMesh, ownedElemCoords=ownedElemCoords, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! loop through and set field
do i1=1,numOwnedElems
! Get coords
lon=ownedElemCoords(2*i1-1)
lat=ownedElemCoords(2*i1)
! Set source function
theta = DEG2RAD*(lon)
phi = DEG2RAD*(90.-lat)
x = cos(theta)*sin(phi)
y = sin(theta)*sin(phi)
z = cos(phi)
srcFarrayPtr(i1) = x+y+z
!srcFarrayPtr(i1) = 1.0
enddo
! Deallocate space for coordinates
deallocate(ownedElemCoords)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!! Setup Destination !!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Create Destination Mesh
call createTestMesh3x3(dstMesh, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Array spec
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
! Create dest. field
dstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. area field
dstAreaField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_area", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create exact dest. field
xdstField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="xdest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init destination field to 0.0
! Should only be 1 localDE
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Init exact destination field
! Should only be 1 localDE
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Set number of points in destination mesh
call ESMF_MeshGet(dstMesh, numOwnedElements=numOwnedElems, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! Allocate space for coordinates
allocate(ownedElemCoords(2*numOwnedElems))
! Set exact destination field
call ESMF_MeshGet(dstMesh, ownedElemCoords=ownedElemCoords, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! loop through and set xfield
do i1=1,numOwnedElems
! Get coords
lon=ownedElemCoords(2*i1-1)
lat=ownedElemCoords(2*i1)
! Set exact dest function
theta = DEG2RAD*(lon)
phi = DEG2RAD*(90.-lat)
x = cos(theta)*sin(phi)
y = sin(theta)*sin(phi)
z = cos(phi)
xdstFarrayPtr(i1) = x+y+z
! xdstFarrayPtr(i1) = 1.0
! Init destination field to 0.0
dstFarrayPtr(i1)=0.0
enddo
! Deallocate space for coordinates
deallocate(ownedElemCoords)
#if 0
call ESMF_MeshWrite(srcMesh,"srcMesh")
call ESMF_MeshWrite(dstMesh,"dstMesh")
#endif
!!! Regrid forward from the A grid to the B grid
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
dstField=dstField, &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Do regrid
call ESMF_FieldRegrid(srcField, dstField, routeHandle, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(srcAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Get the integration weights
call ESMF_FieldRegridGetArea(dstAreaField, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check if the values are close
minerror(1) = 100000.
maxerror(1) = 0.
error = 0.
errorTot=0.0
num_errorTot=0
dstmass = 0.
! get dst Field
call ESMF_FieldGet(dstField, 0, dstFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get exact destination Field
call ESMF_FieldGet(xdstField, 0, xdstFarrayPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get dst area Field
call ESMF_FieldGet(dstAreaField, 0, dstAreaPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(dstFracField, 0, dstFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! destination grid
!! check relative error
do i1=clbnd(1),cubnd(1)
! This is WRONG, shouldn't include Frac
! dstmass = dstmass + dstFracptr(i1,i2)*dstAreaptr(i1)*fptr(i1)
! Instead do this
dstmass = dstmass + dstAreaptr(i1)*dstFarrayPtr(i1)
! If this destination cell isn't covered by a sig. amount of source, then don't compute error on it.
if (dstFracPtr(i1) .lt. 0.1) cycle
! write(*,*) i1,"::",dstFarrayPtr(i1),xdstFarrayPtr(i1)
! Since fraction isn't included in weights in this case, use it to modify dstField value, so
! that it's correct for partial cells
if (dstFracPtr(i1) .ne. 0.0) then
dstVal=dstFarrayPtr(i1)/dstFracptr(i1)
else
dstVal=dstFarrayPtr(i1)
endif
if (xdstFarrayPtr(i1) .ne. 0.0) then
error=ABS(dstVal - xdstFarrayPtr(i1))/ABS(xdstFarrayPtr(i1))
else
error=ABS(dstVal - xdstFarrayPtr(i1))
endif
! total error
errorTot=errorTot+error
num_errorTot=num_errorTot+1
! min max error
if (error > maxerror(1)) then
maxerror(1) = error
endif
if (error < minerror(1)) then
minerror(1) = error
endif
enddo
srcmass(1) = 0.
! get src pointer
call ESMF_FieldGet(srcField, 0, srcFarrayPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get src Field
call ESMF_FieldGet(srcAreaField, 0, srcAreaptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! get frac Field
call ESMF_FieldGet(srcFracField, 0, srcFracptr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
srcmass(1) = srcmass(1) + srcFracptr(i1)*srcAreaptr(i1)*srcFarrayPtr(i1)
enddo
srcmassg(1) = 0.
dstmassg(1) = 0.
call ESMF_VMAllReduce(vm, srcmass, srcmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, dstmass, dstmassg, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, maxerror, maxerrorg, 1, ESMF_REDUCE_MAX, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_VMAllReduce(vm, minerror, minerrorg, 1, ESMF_REDUCE_MIN, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
l_errorTot(1)=errorTot
call ESMF_VMAllReduce(vm, l_errorTot, g_errorTot, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
l_num_errorTot(1)=num_errorTot
call ESMF_VMAllReduce(vm, l_num_errorTot, g_num_errorTot, 1, ESMF_REDUCE_SUM, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flags
csrv = .false.
if (ABS(dstmassg(1)-srcmassg(1))/srcmassg(1) < 10E-10) csrv = .true.
itrp = .false.
if (maxerrorg(1) < 10E-2) itrp = .true.
! Uncomment these calls to see some actual regrid results
if (localPet == 0) then
write(*,*)
write(*,*) "=== Conservative Mesh to Mesh using easy elems ==="
write(*,*) "Conservation:"
write(*,*) "Rel Error = ", ABS(dstmassg(1)-srcmassg(1))/srcmassg(1)
write(*,*) "SRC mass = ", srcmassg(1)
write(*,*) "DST mass = ", dstmassg(1)
write(*,*) " "
write(*,*) "Interpolation:"
write(*,*) "Max Error = ", maxerrorg(1)
write(*,*) "Min Error = ", minerrorg(1)
write(*,*) "Avg Error = ", g_errorTot(1)/g_num_errorTot(1)
write(*,*) " "
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstAreaField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(xdstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the meshes
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! rc, itrp, csrv init to success above
end subroutine test_MeshEasyElems
subroutine test_regridDisjoint(rc)
integer, intent(out) :: rc
logical :: correct
integer :: localrc
type(ESMF_VM) :: vm
type(ESMF_Mesh) :: dstMesh
type(ESMF_Mesh) :: srcMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField, regridStatusField
type(ESMF_Array) :: dstArray
type(ESMF_Array) :: lonArrayA
type(ESMF_Array) :: srcArrayA
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_Field) :: srcFracField, dstFracField
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
real(ESMF_KIND_R8), pointer :: farrayPtrXC(:,:), farrayPtr1D(:)
real(ESMF_KIND_R8), pointer :: farrayPtrYC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtr(:,:),farrayPtr2(:,:)
integer(ESMF_KIND_I4), pointer :: statusPtr(:)
integer :: fclbnd(2),fcubnd(2)
integer :: i1,i2,i3, index(2)
integer :: lDE, localDECount
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
real(ESMF_KIND_R8) :: dx,dy
real(ESMF_KIND_R8) :: x,y
integer :: spherical_grid
integer, pointer :: larrayList(:)
integer :: localPet, petCount
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes, numElems
integer :: numQuadElems,numTriElems, numTotElems
! result code
integer :: finalrc
! init success flag
correct=.true.
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
! Setup Src Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/2.9, 2.9, & ! node id 1
4.0, 2.9, & ! node id 2
5.1, 2.9, & ! node id 3
2.9, 4.0, & ! node id 4
4.0, 4.0, & ! node id 5
5.1, 4.0, & ! node id 6
2.9, 5.1, & ! node id 7
4.0, 5.1, & ! node id 8
5.1, 5.1 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numQuadElems=3
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the node mask array.
! Mask out elem 5
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 1
0, & ! elem id 2
0, & ! elem id 3
0, & ! elem id 4
1/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/2.9, 2.9, & ! node id 1
4.0, 2.9, & ! node id 2
2.9, 4.0, & ! node id 4
4.0, 4.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/4.0, 2.9, & ! node id 2
5.1, 2.9, & ! node id 3
4.0, 4.0, & ! node id 5
5.1, 4.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numQuadElems=0
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 2
0/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/2.9, 4.0, & ! node id 4
4.0, 4.0, & ! node id 5
2.9, 5.1, & ! node id 7
4.0, 5.1 /) ! node id 8
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/4.0, 4.0, & ! node id 5
5.1, 4.0, & ! node id 6
4.0, 5.1, & ! node id 8
5.1, 5.1 /) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/1/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementMask=elemMask, &
elementIds=elemIds, elementTypes=elemTypes, &
elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source field
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
srcField = ESMF_FieldCreate(srcMesh, arrayspec, &
meshLoc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
deallocate(elemMask)
! Create Dest Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.5,-0.5, & ! node id 1 Put outside the src grid
1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
0.0,1.0, & ! node id 4
1.2,1.2, & ! node id 5
2.0,1.1, & ! node id 6
0.0,2.0, & ! node id 7
1.1,2.0, & ! node id 8
2.0,2.0 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numQuadElems=3
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the node mask array.
! Mask out node 9
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 1
0, & ! elem id 2
2, & ! elem id 3
0, & ! elem id 4
0/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.5,-0.5, & ! node id 1 Put outside src grid
1.0, 0.0, & ! node id 2
0.0, 1.0, & ! node id 4
1.2, 1.2 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.0, & ! node id 2
2.0,0.0, & ! node id 3
1.2,1.2, & ! node id 5
2.0,1.1 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numQuadElems=0
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 2
2/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,1.0, & ! node id 4
1.2,1.2, & ! node id 5
0.0,2.0, & ! node id 7
1.1,2.0 /) ! node id 8
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.2,1.2, & ! node id 5
2.0,1.1, & ! node id 6
1.1,2.0, & ! node id 8
2.0,2.0 /) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementMask=elemMask, &
elementIds=elemIds, elementTypes=elemTypes, &
elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemMask)
deallocate(elemConn)
! Create dest field
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
dstField = ESMF_FieldCreate(dstMesh, arrayspec, &
meshLoc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create regrid status field
regridStatusField=ESMF_FieldCreate(dstMesh, ESMF_TYPEKIND_I4, &
meshLoc=ESMF_MESHLOC_ELEMENT, &
name="regrid status", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
srcMaskValues=(/1/), &
dstField=dstField, &
dstMaskValues=(/2/), &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
dstStatusField=regridStatusField, &
unmappedAction=ESMF_UNMAPPEDACTION_IGNORE, &
rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldRegridRelease(routeHandle, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Check destination field
! Should only be 1 localDE
call ESMF_FieldGet(regridStatusField, 0, statusPtr, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! write(*,*) localPet," Status Field=",statusPtr
! Check status
correct=.true.
if (PetCount .eq. 1) then
if (statusPtr(1) .ne. ESMF_REGRIDSTATUS_OUTSIDE) correct=.false.
if (statusPtr(2) .ne. ESMF_REGRIDSTATUS_OUTSIDE) correct=.false.
if (statusPtr(3) .ne. ESMF_REGRIDSTATUS_DSTMASKED) correct=.false.
if (statusPtr(4) .ne. ESMF_REGRIDSTATUS_OUTSIDE) correct=.false.
if (statusPtr(5) .ne. ESMF_REGRIDSTATUS_OUTSIDE) correct=.false.
else if (petCount .eq. 4) then
if (localPET .eq. 0) then !!! This part only for PET 0
! Check status for elemIds=(/1/)
if (statusPtr(1) .ne. ESMF_REGRIDSTATUS_OUTSIDE) correct=.false.
else if (localPET .eq. 1) then !!! This part only for PET 1
! Check status for elemIds=(/2,3/)
if (statusPtr(1) .ne. ESMF_REGRIDSTATUS_OUTSIDE) correct=.false.
if (statusPtr(2) .ne. ESMF_REGRIDSTATUS_DSTMASKED) correct=.false.
else if (localPET .eq. 2) then !!! This part only for PET 2
! Check status for elemIds=(/4/)
if (statusPtr(1) .ne. ESMF_REGRIDSTATUS_OUTSIDE) correct=.false.
else if (localPET .eq. 3) then !!! This part only for PET 3
! Check status for elemIds=(/5/)
if (statusPtr(1) .ne. ESMF_REGRIDSTATUS_OUTSIDE) correct=.false.
endif
endif
! Make sure src fraction is all 0
call ESMF_FieldGet(srcFracField, 0, srcFracPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
if (srcFracPtr(i1) .ne. 0.0) correct=.false.
enddo
! Make sure dst fraction is all 0
call ESMF_FieldGet(dstFracField, 0, dstFracPtr, computationalLBound=clbnd, &
computationalUBound=cubnd, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
do i1=clbnd(1),cubnd(1)
if (dstFracPtr(i1) .ne. 0.0) correct=.false.
enddo
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(regridStatusField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the Meshes
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! return answer based on correct flag
if (correct) then
rc=ESMF_SUCCESS
else
rc=ESMF_FAILURE
endif
end subroutine test_regridDisjoint
subroutine test_overlap_error(rc)
integer, intent(out) :: rc
logical :: correct
integer :: localrc
type(ESMF_VM) :: vm
type(ESMF_Mesh) :: dstMesh
type(ESMF_Mesh) :: srcMesh
type(ESMF_Field) :: srcField
type(ESMF_Field) :: dstField
type(ESMF_Array) :: dstArray
type(ESMF_Array) :: lonArrayA
type(ESMF_Array) :: srcArrayA
type(ESMF_RouteHandle) :: routeHandle
type(ESMF_ArraySpec) :: arrayspec
type(ESMF_Field) :: srcFracField, dstFracField
real(ESMF_KIND_R8), pointer :: srcFracPtr(:), dstFracPtr(:)
integer :: clbnd(1),cubnd(1)
real(ESMF_KIND_R8), pointer :: farrayPtrXC(:,:), farrayPtr1D(:)
real(ESMF_KIND_R8), pointer :: farrayPtrYC(:,:)
real(ESMF_KIND_R8), pointer :: farrayPtr(:,:),farrayPtr2(:,:)
integer(ESMF_KIND_I4), pointer :: statusPtr(:)
integer :: fclbnd(2),fcubnd(2)
integer :: i1,i2,i3, index(2)
integer :: lDE, localDECount
real(ESMF_KIND_R8) :: coord(2)
character(len=ESMF_MAXSTR) :: string
real(ESMF_KIND_R8) :: dx,dy
real(ESMF_KIND_R8) :: x,y
integer :: spherical_grid
integer, pointer :: larrayList(:)
integer :: localPet, petCount
integer, pointer :: nodeIds(:),nodeOwners(:)
real(ESMF_KIND_R8), pointer :: nodeCoords(:)
integer, pointer :: elemIds(:),elemTypes(:),elemConn(:),elemMask(:)
integer :: numNodes, numElems
integer :: numQuadElems,numTriElems, numTotElems
! result code
integer :: finalrc
! init success flag
correct=.true.
rc=ESMF_SUCCESS
! get pet info
call ESMF_VMGetGlobal(vm, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_VMGet(vm, petCount=petCount, localPet=localpet, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! If we don't have 1 or 4 PETS then exit successfully
if ((petCount .ne. 1) .and. (petCount .ne. 4)) then
print*,'ERROR: test must be run using exactly 1 or 4 PETS - detected ',petCount
rc=ESMF_FAILURE
return
endif
! Setup Src Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/2.9, 2.9, & ! node id 1
4.0, 2.9, & ! node id 2
5.1, 2.9, & ! node id 3
2.9, 4.0, & ! node id 4
4.0, 4.0, & ! node id 5
5.1, 4.0, & ! node id 6
2.9, 5.1, & ! node id 7
4.0, 5.1, & ! node id 8
5.1, 5.1 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numQuadElems=3
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the node mask array.
! Mask out elem 5
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 1
0, & ! elem id 2
0, & ! elem id 3
0, & ! elem id 4
1/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
3,6,5, & ! elem id 3
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/2.9, 2.9, & ! node id 1
4.0, 2.9, & ! node id 2
2.9, 4.0, & ! node id 4
4.0, 4.0 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5,6/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/4.0, 2.9, & ! node id 2
5.1, 2.9, & ! node id 3
4.0, 4.0, & ! node id 5
5.1, 4.0 /) ! node id 6
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0, & ! node id 5
1/) ! node id 6
! Set the number of each type of element, plus the total number.
numQuadElems=0
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 2
0/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,3, & ! elem id 2
2,4,3/) ! elem id 3
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/2.9, 4.0, & ! node id 4
4.0, 4.0, & ! node id 5
2.9, 5.1, & ! node id 7
4.0, 5.1 /) ! node id 8
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/4.0, 4.0, & ! node id 5
5.1, 4.0, & ! node id 6
4.0, 5.1, & ! node id 8
5.1, 5.1 /) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
1, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/1/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
srcMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementMask=elemMask, &
elementIds=elemIds, elementTypes=elemTypes, &
elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source field
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
srcField = ESMF_FieldCreate(srcMesh, arrayspec, &
meshLoc=ESMF_MESHLOC_ELEMENT, &
name="source", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create source frac field
srcFracField = ESMF_FieldCreate(srcMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="source_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemConn)
deallocate(elemMask)
! Create Dest Mesh
if (petCount .eq. 1) then
! Set number of nodes
numNodes=9
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,3,4,5,6,7,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.5,-0.5, & ! node id 1 Put outside the src grid
1.0,0.0, & ! node id 2
3.0,0.0, & ! node id 3
0.0,1.0, & ! node id 4
1.2,1.2, & ! node id 5
3.0,1.1, & ! node id 6
0.0,3.0, & ! node id 7
1.1,3.0, & ! node id 8
3.0,3.0 /) ! node id 9
! Allocate and fill the node owner array.
! Since this Mesh is all on PET 0, it's just set to all 0.
allocate(nodeOwners(numNodes))
nodeOwners=0 ! everything on PET 0
! Set the number of each type of element, plus the total number.
numQuadElems=3
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1,2,3,4,5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD, & ! elem id 1
ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI, & ! elem id 3
ESMF_MESHELEMTYPE_QUAD, & ! elem id 4
ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the node mask array.
! Mask out node 9
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 1
0, & ! elem id 2
0, & ! elem id 3
0, & ! elem id 4
0/) ! elem id 5
! Allocate and fill the element connection type array.
! Note that entries in this array refer to the
! positions in the nodeIds, etc. arrays and that
! the order and number of entries for each element
! reflects that given in the Mesh options
! section for the corresponding entry
! in the elemTypes array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,5,4, & ! elem id 1
2,3,5, & ! elem id 2
2,3,5, & ! elem id 3 MAKE ELEM 3 THE SAME AS 2
4,5,8,7, & ! elem id 4
5,6,9,8/) ! elem id 5
else if (petCount .eq. 4) then
! Setup mesh data depending on PET
if (localPET .eq. 0) then !!! This part only for PET 0
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/1,2,4,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/-0.5,-0.5, & ! node id 1 Put outside src grid
1.0, 0.0, & ! node id 2
0.0, 1.0, & ! node id 4
1.2, 1.2 /) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 1
0, & ! node id 2
0, & ! node id 4
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/1/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 1
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 1
! Allocate and fill the element connection type array.
! Note that entry are local indices
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 1
else if (localPET .eq. 1) then !!! This part only for PET 1
! Set number of nodes
numNodes=3
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/2,3,5/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.0,0.0, & ! node id 2
3.0,0.0, & ! node id 3
1.2,1.2/) ! node id 5
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 2
1, & ! node id 3
0/) ! node id 5
! Set the number of each type of element, plus the total number.
numQuadElems=0
numTriElems=2
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/2,3/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_TRI, & ! elem id 2
ESMF_MESHELEMTYPE_TRI/) ! elem id 3
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0, & ! elem id 2
0/) ! elem id 3
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,3, & ! elem id 2
1,2,3/) ! elem id 3 MAKE ELEM 3 THE SAME AS 2
else if (localPET .eq. 2) then !!! This part only for PET 2
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/4,5,7,8/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/0.0,1.0, & ! node id 4
1.2,1.2, & ! node id 5
0.0,3.0, & ! node id 7
1.1,3.0 /) ! node id 8
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 4
0, & ! node id 5
2, & ! node id 7
2/) ! node id 8
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/4/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 4
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 4
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 4
else if (localPET .eq. 3) then !!! This part only for PET 3
! Set number of nodes
numNodes=4
! Allocate and fill the node id array.
allocate(nodeIds(numNodes))
nodeIds=(/5,6,8,9/)
! Allocate and fill node coordinate array.
! Since this is a 2D Mesh the size is 2x the
! number of nodes.
allocate(nodeCoords(2*numNodes))
nodeCoords=(/1.2,1.2, & ! node id 5
3.0,1.1, & ! node id 6
1.1,3.0, & ! node id 8
3.0,3.0 /) ! node id 9
! Allocate and fill the node owner array.
allocate(nodeOwners(numNodes))
nodeOwners=(/0, & ! node id 5
3, & ! node id 6
2, & ! node id 8
3/) ! node id 9
! Set the number of each type of element, plus the total number.
numQuadElems=1
numTriElems=0
numTotElems=numQuadElems+numTriElems
! Allocate and fill the element id array.
allocate(elemIds(numTotElems))
elemIds=(/5/)
! Allocate and fill the element topology type array.
allocate(elemTypes(numTotElems))
elemTypes=(/ESMF_MESHELEMTYPE_QUAD/) ! elem id 5
! Allocate and fill the elem mask array.
allocate(elemMask(numTotElems))
elemMask=(/0/) ! elem id 5
! Allocate and fill the element connection type array.
allocate(elemConn(4*numQuadElems+3*numTriElems))
elemConn=(/1,2,4,3/) ! elem id 5
endif
endif
! Create Mesh structure in 1 step
dstMesh=ESMF_MeshCreate(parametricDim=2,spatialDim=2, &
nodeIds=nodeIds, nodeCoords=nodeCoords, &
nodeOwners=nodeOwners, elementMask=elemMask, &
elementIds=elemIds, elementTypes=elemTypes, &
elementConn=elemConn, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! deallocate node data
deallocate(nodeIds)
deallocate(nodeCoords)
deallocate(nodeOwners)
! deallocate elem data
deallocate(elemIds)
deallocate(elemTypes)
deallocate(elemMask)
deallocate(elemConn)
! Create dest field
call ESMF_ArraySpecSet(arrayspec, 1, ESMF_TYPEKIND_R8, rc=rc)
dstField = ESMF_FieldCreate(dstMesh, arrayspec, &
meshLoc=ESMF_MESHLOC_ELEMENT, &
name="dest", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Create dest. frac field
dstFracField = ESMF_FieldCreate(dstMesh, arrayspec, meshloc=ESMF_MESHLOC_ELEMENT, &
name="dest_frac", rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Regrid store
call ESMF_FieldRegridStore( &
srcField, &
srcMaskValues=(/1/), &
dstField=dstField, &
dstMaskValues=(/2/), &
routeHandle=routeHandle, &
regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
dstFracField=dstFracField, &
srcFracField=srcFracField, &
unmappedAction=ESMF_UNMAPPEDACTION_IGNORE, &
checkFlag=.true., &
rc=localrc)
! This should fail because grids are overlapping,
! so if it's a SUCCESS report it as failure
if (localrc == ESMF_SUCCESS) then
rc=ESMF_FAILURE
endif
! Destroy the Fields
call ESMF_FieldDestroy(srcField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(srcFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_FieldDestroy(dstFracField, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
! Free the Meshes
call ESMF_MeshDestroy(dstMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
call ESMF_MeshDestroy(srcMesh, rc=localrc)
if (localrc /=ESMF_SUCCESS) then
rc=ESMF_FAILURE
return
endif
end subroutine test_overlap_error
end program ESMF_FieldRegridCsrvUTest