subroutine test7d4_generic(rc, minindex, maxindex, &
gridEdgeLWidth, gridEdgeUWidth, &
regDecomp, &
distgridToGridMap, &
datacopyflag, &
staggerloc, &
gridToFieldMap, &
ungriddedLBound, ungriddedUBound, &
totalLWidth, totalUWidth, &
fieldget)
! input arguments
integer, intent(out) :: rc
integer, dimension(:) :: minIndex
integer, dimension(:) :: maxIndex
integer, dimension(:), optional :: gridEdgeLWidth, gridEdgeUWidth
integer, dimension(:), optional :: regDecomp
integer, dimension(:), optional :: distgridToGridMap
type(ESMF_DataCopy_Flag), optional :: datacopyflag
type(ESMF_STAGGERLOC), optional :: staggerloc
integer, dimension(:), optional :: gridToFieldMap
integer, dimension(:), optional :: ungriddedLBound, ungriddedUBound
integer, dimension(:), optional :: totalLWidth, totalUWidth
logical, optional :: fieldget
! local arguments used to create field
type(ESMF_Field) :: field
type(ESMF_Array) :: array
type(ESMF_Grid) :: grid
type(ESMF_DistGrid) :: distgrid
type(ESMF_DistGrid) :: staggerDistgrid
integer :: localrc
integer :: flb(7), fub(7)
! local arguments used to get info from field
type(ESMF_Grid) :: grid1, grid2
type(ESMF_Array) :: array1, array2
type(ESMF_TypeKind_Flag) :: typekind
integer :: dimCount
type(ESMF_StaggerLoc) :: lstaggerloc
integer, dimension(7) :: lgridToFieldMap
integer, dimension(7) :: lungriddedLBound
integer, dimension(7) :: lungriddedUBound
integer, dimension(7,1) :: ltotalLWidth
integer, dimension(7,1) :: ltotalUWidth
! local arguments used to verify field get
integer :: i, ii, ij, ik, il, im, io, ip
integer, dimension(7) :: felb, feub, fclb, fcub, ftlb, ftub
integer, dimension(7) :: fec, fcc, ftc
real(ESMF_KIND_R8), dimension(:,:,:,:,:,:,:), allocatable :: farray
real(ESMF_KIND_R8), dimension(:,:,:,:,:,:,:), pointer :: farray1
real(ESMF_KIND_R8) :: n
integer, dimension(7,1) :: aelb, aeub, aclb, acub, atlb, atub
integer :: ldec, ldel(1)
integer, dimension(:), allocatable :: audlb, audub
integer :: arank, adimCount, gdimCount
integer, dimension(:), allocatable :: l_g2fm, l_dg2gm, distgridToArrayMap
integer, dimension(:), allocatable :: l_mhlw, l_mhuw, celw, ceuw
type(ESMF_Field) :: field1
character, pointer :: buffer(:)
integer :: buff_length, offset
integer :: gminIndex(7), gmaxIndex(7), geleCount(7)
integer :: lminIndex(7), lmaxIndex(7), leleCount(7)
localrc = ESMF_SUCCESS
rc = ESMF_SUCCESS
! create distgrid
distgrid = ESMF_DistGridCreate(minIndex=minIndex, maxIndex=maxIndex, &
regDecomp=regDecomp, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! create grid
grid = ESMF_GridCreate(distgrid=distgrid, name="grid", &
distgridToGridMap=distgridToGridMap, &
gridEdgeLWidth=gridEdgeLWidth, gridEdgeUWidth=gridEdgeUWidth, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! get distgrid for staggerloc
if (present(staggerloc)) then
call ESMF_GridGet(grid,staggerloc, &
distgrid=staggerdistgrid,rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
else
call ESMF_GridGet(grid,ESMF_STAGGERLOC_CENTER, &
distgrid=staggerdistgrid,rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
call ESMF_GridGetFieldBounds(grid, localDe=0, &
staggerloc=staggerloc,&
ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, &
totalLWidth=totalLWidth, totalUWidth=totalUWidth, &
gridToFieldMap=gridToFieldMap, &
totalLBound=flb, totalUBound=fub, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! prepare input to ESMF_ArrayCreate
! array pointer
allocate(farray(flb(1):fub(1), flb(2):fub(2), flb(3):fub(3), &
flb(4):fub(4), flb(5):fub(5), flb(6):fub(6), flb(7):fub(7)) )
if(present(fieldget)) then
if(fieldget) then
! reverse looping order to make this a little faster by improving data locality
do ip = flb(7), fub(7)
do io = flb(6), fub(6)
do im = flb(5), fub(5)
do il = flb(4), fub(4)
do ik = flb(3), fub(3)
do ij = flb(2), fub(2)
do ii = flb(1), fub(1)
farray(ii,ij,ik,il,im,io,ip) = ii+ij*2+ik+il*2+im+io*2+ip
enddo
enddo
enddo
enddo
enddo
enddo
enddo
endif
endif
gdimCount = size(minIndex, 1)
allocate( distgridToArrayMap(gdimCount), l_g2fm(gdimCount), l_dg2gm(gdimCount) )
allocate( l_mhlw(gdimCount), l_mhuw(gdimCount), celw(gdimCount), ceuw(gdimCount) )
if(present(gridToFieldMap)) then
l_g2fm(1:gdimCount) = gridToFieldMap(1:gdimCount)
else
do i = 1, gdimCount
l_g2fm(i) = i
enddo
endif
if(present(distgridToGridMap)) then
l_dg2gm(1:gdimCount) = distgridToGridMap(1:gdimCount)
else
do i = 1, gdimCount
l_dg2gm(i) = i
enddo
endif
if(present(totalLWidth)) then
l_mhlw(1:gdimCount) = totalLWidth(1:gdimCount)
else
l_mhlw = 0
endif
if(present(totalUWidth)) then
l_mhuw(1:gdimCount) = totalUWidth(1:gdimCount)
else
l_mhuw = 0
endif
! hardcode these, or call GridGetUndistInfo
celw = 0
ceuw = -1
do i = 1, gdimCount
distgridToArrayMap(i) = l_g2fm(l_dg2gm(i))
enddo
! create array
array = ESMF_ArrayCreate(staggerdistgrid, farray, &
indexflag=ESMF_INDEX_DELOCAL, datacopyflag=datacopyflag, &
distgridToArrayMap=distgridToArrayMap, &
undistLBound=ungriddedLBound, undistUBound=ungriddedUBound, &
totalLWidth=totalLWidth, totalUWidth=totalUWidth, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! create field
field = ESMF_FieldCreate(grid, array, datacopyflag=datacopyflag, &
gridToFieldMap=gridToFieldMap, &
ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, &
totalLWidth=totalLWidth, totalUWidth=totalUWidth, &
staggerloc=staggerloc, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
if(present(fieldget)) then
if(fieldget) then
! verify FieldGetDataBounds are correct
call ESMF_FieldGet(field, localDe=0, farrayPtr=farray1, &
exclusiveLBound=felb, exclusiveUBound=feub, exclusiveCount=fec, &
computationalLBound=fclb, computationalUBound=fcub, computationalCount=fcc, &
totalLBound=ftlb, totalUBound=ftub, totalCount=ftc, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldGet(field, grid=grid1, array=array1, typekind=typekind, &
dimCount=dimCount, staggerloc=lstaggerloc, gridToFieldMap=lgridToFieldMap, &
ungriddedLBound=lungriddedLBound, ungriddedUBound=lungriddedUBound, &
totalLWidth=ltotalLWidth, totalUWidth=ltotalUWidth, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! verify parameters from getdefault are correct
if(present(gridToFieldMap)) then
do i = 1, size(gridToFieldMap)
if(lgridToFieldMap(i) .ne. gridToFieldMap(i)) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
if(present(ungriddedLBound)) then
do i = 1, size(ungriddedLBound)
if(lungriddedLBound(i) .ne. ungriddedLBound(i)) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
if(present(ungriddedUBound)) then
do i = 1, size(ungriddedUBound)
if(lungriddedUBound(i) .ne. ungriddedUBound(i)) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
if(present(totalLWidth)) then
do i = 1, size(totalLWidth)
if(ltotalLWidth(i,1) .ne. totalLWidth(i)) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
if(present(totalUWidth)) then
do i = 1, size(totalUWidth)
if(ltotalUWidth(i,1) .ne. totalUWidth(i)) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
! Allocate serialization buffer
buff_length = 1
allocate (buffer(0:buff_length-1))
offset = 0
call ESMF_FieldSerialize(field, buffer, buff_length, offset, &
inquireflag=ESMF_INQUIREONLY, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
deallocate (buffer)
buff_length = offset
allocate (buffer(0:buff_length-1))
! call serialize and deserialize and verify again
offset = 0
call ESMF_FieldSerialize(field, buffer, buff_length, offset, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
offset = 0
field1 = ESMF_FieldDeserialize(buffer, offset, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
deallocate (buffer)
call ESMF_FieldValidate(field1, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldGet(field1, grid=grid2, array=array2, typekind=typekind, &
dimCount=dimCount, staggerloc=lstaggerloc, gridToFieldMap=lgridToFieldMap, &
ungriddedLBound=lungriddedLBound, ungriddedUBound=lungriddedUBound, &
totalLWidth=ltotalLWidth, totalUWidth=ltotalUWidth, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! verify parameters from getdefault are correct from a deseriailzed field
if(present(gridToFieldMap)) then
do i = 1, size(gridToFieldMap)
if(lgridToFieldMap(i) .ne. gridToFieldMap(i)) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
if(present(ungriddedLBound)) then
do i = 1, size(ungriddedLBound)
if(lungriddedLBound(i) .ne. ungriddedLBound(i)) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
if(present(ungriddedUBound)) then
do i = 1, size(ungriddedUBound)
if(lungriddedUBound(i) .ne. ungriddedUBound(i)) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
if(present(totalLWidth)) then
do i = 1, size(totalLWidth)
if(ltotalLWidth(i,1) .ne. totalLWidth(i)) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
if(present(totalUWidth)) then
do i = 1, size(totalUWidth)
if(ltotalUWidth(i,1) .ne. totalUWidth(i)) localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif
! verify that the field and array bounds agree with each other
call ESMF_ArrayGet(array, rank=arank, dimCount=adimCount, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
allocate(audlb(arank-adimCount), audub(arank-adimCount))
call ESMF_ArrayGet(array, exclusiveLBound=aelb, exclusiveUBound=aeub, &
computationalLBound=aclb, computationalUBound=acub, &
totalLBound=atlb, totalUBound=atub, &
localDeCount=ldec, localDeToDeMap=ldel, &
undistLBound=audlb, undistUBound=audub, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! verify the numbers returned are correct
if(ldec .ne. 1) localrc = ESMF_FAILURE
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
!ldel(1) is PET dependent
!if(ldel(1) .ne. 0) localrc = ESMF_FAILURE
!if (ESMF_LogFoundError(localrc, &
! ESMF_ERR_PASSTHRU, &
! ESMF_CONTEXT, rcToReturn=rc)) return
do i = 1, arank-adimCount
if(lungriddedLBound(i) .ne. audlb(i) ) &
localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
do i = 1, arank-adimCount
if(lungriddedUBound(i) .ne. audub(i) ) &
localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! compare the total bounds computed from FieldGetAllocBounds and FieldGetDataBounds
do i = 1, 7
if( (ftlb(i) .ne. flb(i)) .or. (ftub(i) .ne. fub(i)) ) &
localrc = ESMF_FAILURE
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
! access and verify
call ESMF_FieldGet(field, localDe=0, farrayPtr=farray1, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
do ip = ftlb(7), ftub(7)
do io = ftlb(6), ftub(6)
do im = ftlb(5), ftub(5)
do il = ftlb(4), ftub(4)
do ik = ftlb(3), ftub(3)
do ij = ftlb(2), ftub(2)
do ii = ftlb(1), ftub(1)
n = ii+ij*2+ik+il*2+im+io*2+ip
if(farray1(ii,ij,ik,il,im,io,ip) .ne. n ) localrc = ESMF_FAILURE
enddo
enddo
enddo
enddo
enddo
enddo
enddo
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_FieldGet(field, minIndex = gminIndex, maxIndex = gmaxIndex, &
elementCount = geleCount, &
localMinIndex = lminIndex, &
localMaxIndex = lmaxIndex, &
localelementCount = leleCount, &
rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
endif ! fieldget = .true.
endif ! present(fieldget) = .true.
call ESMF_FieldDestroy(field, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_GridDestroy(grid, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
call ESMF_DistGridDestroy(distgrid, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
deallocate(farray)
end subroutine test7d4_generic