Skip to content

Commit

Permalink
Implement ESMF_FieldCreateFromField() entry point, support array
Browse files Browse the repository at this point in the history 
slicing. Test array slicing feature in UTest.
Also make ESMF_FieldCreateGBArray() entry point public (BOP).
  • Loading branch information
@theurich
theurich committed Sep 19, 2023
1 parent 1a9ec72 commit 14001ed
Show file tree
Hide file tree
Showing 2 changed files with 210 additions and 4 deletions.
116 changes: 113 additions & 3 deletions src/Infrastructure/Field/src/ESMF_FieldCreate.cppF90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -51,6 +51,7 @@ module ESMF_FieldCreateMod
use ESMF_VMMod

use ESMF_FieldMod
use ESMF_FieldGetMod
use ESMF_FieldEmptyMod

implicit none
Expand Down Expand Up @@ -124,6 +125,7 @@ module ESMF_FieldCreateMod
TypeKindRankInterfaceMacro(FieldCreateXGData)
TypeKindRankInterfaceMacro(FieldCreateXGDataPtr)

module procedure ESMF_FieldCreateFromField

! !DESCRIPTION:
! This interface provides an entry point for methods that create a complete
Expand Down Expand Up @@ -993,7 +995,7 @@ end function ESMF_FieldCreateGBTKR
!------------------------------------------------------------------------------
^undef ESMF_METHOD
^define ESMF_METHOD "ESMF_FieldCreateGBArray"
!BOPI
!BOP
! !IROUTINE: ESMF_FieldCreate - Create a Field from Geom and Array

! !INTERFACE:
Expand Down Expand Up @@ -1093,7 +1095,7 @@ end function ESMF_FieldCreateGBTKR
! \item [{[rc]}]
! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
! \end{description}
!EOPI
!EOP
!------------------------------------------------------------------------------
type(ESMF_FieldType), pointer :: ftype ! Pointer to new field
integer :: localrc ! Local error code
Expand Down Expand Up @@ -2759,7 +2761,7 @@ type(ESMF_KeywordEnforcer), optional:: keywordEnforcer ! must use keywords below
return @\
endif @\
endif@\
! Error check staggerloc @\
! Error check staggerloc @\
if (present(staggerloc)) then @\
if ((decompType .eq. ESMF_GRID_ARBITRARY) .and. & @\
(staggerloc .ne. ESMF_STAGGERLOC_CENTER)) then @\
Expand Down Expand Up @@ -5057,6 +5059,114 @@ TypeKindRankDeclarationMacro(FieldCreateXGDataPtr)
!------------------------------------------------------------------------------


! -------------------------- ESMF-public method -------------------------------
^undef ESMF_METHOD
^define ESMF_METHOD "ESMF_FieldCreateFromField()"
!BOP
! !IROUTINE: ESMF_FieldCreate - Create Field object from an existing Field object

! !INTERFACE:
! Private name; call using ESMF_FieldCreate()
function ESMF_FieldCreateFromField(field, keywordEnforcer, datacopyflag, &
trailingUndistSlice, name, rc)
!
! !RETURN VALUE:
type(ESMF_Field) :: ESMF_FieldCreateFromField
!
! !ARGUMENTS:
type(ESMF_Field), intent(in) :: field
type(ESMF_KeywordEnforcer), optional:: keywordEnforcer ! must use keywords below
type(ESMF_DataCopy_Flag), intent(in), optional :: datacopyflag
integer, intent(in), optional :: trailingUndistSlice(:)
character (len=*), intent(in), optional :: name
integer, intent(out), optional :: rc
!
! !DESCRIPTION:
! Create an {\tt ESMF\_Field} object from an existing Field.
!
! The return value is the newly created {\tt ESMF\_Field} object. Supports array
! slicing.
!
! The arguments are:
! \begin{description}
! \item[field]
! {\tt ESMF\_Field} object to be used as originator.
! \item[{[datacopyflag]}]
! Specifies whether the created Field object references the memory
! allocation provided by {\tt field} directly or copies the data from
! {\tt field} into a new memory allocation. For valid values see
! \ref{const:datacopyflag}. The default is {\tt ESMF\_DATACOPY\_VALUE}.
! \item[{[trailingUndistSlice]}]
! If present, the returned Field refers to the array slice of {\tt field}
! as defined by the specified tuple, applied to the right most
! trailing undistributed dimensions.
! \item[{[name]}]
! Name of the Field object.
! \item[{[rc]}]
! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors.
! \end{description}
!
!EOP
!------------------------------------------------------------------------------
integer :: localrc ! local return code
type(ESMF_Array) :: array, arrayOut
type(ESMF_Geom) :: geom
integer :: dimCount, rankOut
integer, allocatable :: gridToFieldMap(:)
integer, allocatable :: ungriddedLBound(:), ungriddedUBound(:)

! Initialize return code; assume failure until success is certain
localrc = ESMF_RC_NOT_IMPL
if (present(rc)) rc = ESMF_RC_NOT_IMPL

ESMF_INIT_CHECK_DEEP_SHORT(ESMF_FieldGetInit, field, rc)

call ESMF_FieldGet(field, array=array, geom=geom, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

call ESMF_GeomGet(geom, dimCount=dimCount, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

allocate(gridToFieldMap(dimCount))
call ESMF_FieldGet(field, gridToFieldMap=gridToFieldMap, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

! created array slice
arrayOut = ESMF_ArrayCreate(array, datacopyflag=datacopyflag, &
trailingUndistSlice=trailingUndistSlice, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

call ESMF_ArrayGet(arrayOut, rank=rankOut, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

allocate(ungriddedLBound(rankOut-dimCount))
allocate(ungriddedUBound(rankOut-dimCount))

call ESMF_ArrayGet(arrayOut, undistLBound=ungriddedLBound, &
undistUBound=ungriddedUBound, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

ESMF_FieldCreateFromField = ESMF_FieldCreate(geom, arrayOut, &
ESMF_DATACOPY_REFERENCE, gridToFieldMap=gridToFieldMap, &
ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, &
! totalLWidth, totalUWidth, &
name=name, rc=localrc)
if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

! Return successfully
if (present(rc)) rc = ESMF_SUCCESS

end function ESMF_FieldCreateFromField
!------------------------------------------------------------------------------


!------------------------------------------------------------------------------
^undef ESMF_METHOD
^define ESMF_METHOD "ESMF_FieldDestroy"
Expand Down
98 changes: 97 additions & 1 deletion src/Infrastructure/Field/tests/ESMF_FieldCreateGetUTest.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -92,7 +92,7 @@ program ESMF_FieldCreateGetUTest
write(failMsg, *) ""
write(name, *) "Create field with global and local indexflag on mesh"
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)

!------------------------------------------------------------------------
!NEX_UTest_Multi_Proc_Only
! Create a field from an fortran 2d array
Expand Down Expand Up @@ -161,6 +161,14 @@ program ESMF_FieldCreateGetUTest
"with bad array size"
call ESMF_Test((rc.ne.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)

!------------------------------------------------------------------------
!NEX_UTest_Multi_Proc_Only
! Create a field from field with array slicing
call test_slicing(rc)
write(failMsg, *) ""
write(name, *) "Creating a Field from Field with slicing"
call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE)

!------------------------------------------------------------------------
!NEX_UTest_Multi_Proc_Only
! Create a field from an fortran 2d array
Expand Down Expand Up @@ -2642,6 +2650,94 @@ subroutine test2a_fail(rc)
ESMF_CONTEXT, rcToReturn=rc)) return
end subroutine test2a_fail

subroutine test_slicing(rc)
integer, intent(out) :: rc
integer :: localrc
type(ESMF_Field) :: field1, field2
type(ESMF_Grid) :: grid
character(80) :: msgStrg
real(ESMF_KIND_R4), pointer :: fptr1(:,:,:,:,:), fptr2(:,:,:)

rc = ESMF_SUCCESS
localrc = ESMF_SUCCESS

grid = ESMF_GridCreateNoPeriDim(minIndex=(/1,1/), maxIndex=(/16,20/), &
regDecomp=(/4,1/), name="testgrid", rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

field1 = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R4, name="Field#1", &
ungriddedLBound=[1,1,1], ungriddedUBound=[10,20,30], rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

field2 = ESMF_FieldCreate(field1, name="Field#2", &
trailingUndistSlice=[1,1], rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

call ESMF_FieldGet(field1, farrayPtr=fptr1, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

write(msgStrg,*) "shape(fptr1)=", shape(fptr1)
call ESMF_LogWrite(msgStrg, ESMF_LOGMSG_INFO, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
write(msgStrg,*) "lbound(fptr1)=", lbound(fptr1)
call ESMF_LogWrite(msgStrg, ESMF_LOGMSG_INFO, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
write(msgStrg,*) "ubound(fptr1)=", ubound(fptr1)
call ESMF_LogWrite(msgStrg, ESMF_LOGMSG_INFO, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

call ESMF_FieldGet(field2, farrayPtr=fptr2, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

write(msgStrg,*) "shape(fptr2)=", shape(fptr2)
call ESMF_LogWrite(msgStrg, ESMF_LOGMSG_INFO, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
write(msgStrg,*) "lbound(fptr2)=", lbound(fptr2)
call ESMF_LogWrite(msgStrg, ESMF_LOGMSG_INFO, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return
write(msgStrg,*) "ubound(fptr2)=", ubound(fptr2)
call ESMF_LogWrite(msgStrg, ESMF_LOGMSG_INFO, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

call ESMF_FieldDestroy(field1, rc=localrc)
if (ESMF_LogFoundError(localrc, &
ESMF_ERR_PASSTHRU, &
ESMF_CONTEXT, rcToReturn=rc)) return

call ESMF_FieldDestroy(field2, 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

end subroutine test_slicing

subroutine test2a_isalloc(datacopyflag, rc)
type(ESMF_DataCopy_Flag), intent(in) :: datacopyflag
integer, intent(out) :: rc
Expand Down

0 comments on commit 14001ed

Please sign in to comment.