! $Id$ ! ! Earth System Modeling Framework ! Copyright (c) 2002-2023, University Corporation for Atmospheric Research, ! Massachusetts Institute of Technology, Geophysical Fluid Dynamics ! Laboratory, University of Michigan, National Centers for Environmental ! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. ! Licensed under the University of Illinois-NCSA License. ! !============================================================================== #define ESMF_FILENAME "ESMF_AttributeUtilUTest.F90" #include "ESMF_Macros.inc" #include "ESMF.h" !============================================================================== !============================================================================== !============================================================================== program ESMF_AttributeUtilUTest !============================================================================== !BOP ! !PROGRAM: ESMF_AttributeUtilUTest ! ! !DESCRIPTION: ! !----------------------------------------------------------------------------- ! !USES: use ESMF_TestMod ! test methods use ESMF use ESMF_AttributeMod, only : ESMF_InfoFormatKey implicit none !------------------------------------------------------------------------------ ! The following line turns the CVS identifier string into a printable variable. character(*), parameter :: version = & '$Id$' !------------------------------------------------------------------------------ !------------------------------------------------------------------------------ !============================================================================== character(ESMF_MAXSTR) :: failMsg character(ESMF_MAXSTR) :: name integer :: rc integer :: result = 0 character(:), allocatable :: key, name_key, convention, purpose type(ESMF_FieldBundle) :: src_fb, dst_fb, src_fb2, dst_fb2, src_fb3, dst_fb3, & fb_idx type(ESMF_Info) :: infoh, infoh2 character(:), allocatable :: actual type(ESMF_Grid) :: grid type(ESMF_Field) :: field,field2,field3,field4 integer :: i,j,count,ii,n character(len=ESMF_MAXSTR) :: attname type(ESMF_TYPEKIND_FLAG) :: tk, actual_tk integer, pointer :: iptr(:) integer, dimension(2) :: atos real(ESMF_KIND_R4), dimension(4) :: arr real(ESMF_KIND_R8), dimension(3) :: arr2 integer :: not_there, actual_value, itemCount !------------------------------------------------------------------------------ ! The unit tests are divided into Sanity and Exhaustive. The Sanity tests are ! always run. When the environment variable, EXHAUSTIVE, is set to ON then ! the EXHAUSTIVE and sanity tests both run. If the EXHAUSTIVE variable is set ! to OFF, then only the sanity unit tests. ! Special strings (Non-exhaustive and exhaustive) have been ! added to allow a script to count the number and types of unit tests. !------------------------------------------------------------------------------ !---------------------------------------------------------------------------- call ESMF_TestStart(ESMF_SRCLINE, rc=rc) ! calls ESMF_Initialize() internally if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "ESMF_InfoFormatKey w/ name" write(failMsg, *) "Did not return ESMF_SUCCESS" name_key = "AttributeName" call ESMF_InfoFormatKey(key, name_key, rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((rc .eq. ESMF_SUCCESS .and. & key .eq. "/ESMF/General/AttributeName"), & name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Attribute copy by reference" write(failMsg, *) "Did not return ESMF_SUCCESS" src_fb = ESMF_FieldBundleCreate(name="src_fb", rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) dst_fb = ESMF_FieldBundleCreate(name="dst_fb", rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeCopy(src_fb, dst_fb, attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_InfoGetFromHost(src_fb, infoh, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_InfoSet(infoh, "/NetCDF/FV3/output_file", "out.nc", rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_InfoGetFromHost(dst_fb, infoh2, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_InfoGetCharAlloc(infoh2, "/NetCDF/FV3/output_file", actual, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((actual .eq. "out.nc"), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Setting scalars and arrays in loop" write(failMsg, *) "Did not return ESMF_SUCCESS" grid = ESMF_GridCreate(countsPerDEDim1=[180], & & countsPerDEDim2=[91], & & indexFlag=ESMF_INDEX_DELOCAL, & & gridEdgeLWidth=[0,0], & & gridEdgeUWidth=[1,1], & & coordDep1=[1,2], & & coordDep2=[1,2], & & coordSys=ESMF_COORDSYS_SPH_RAD, & & rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) field=ESMF_FieldCreate(grid,typekind=ESMF_TYPEKIND_R4,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) field2=ESMF_FieldCreate(grid,typekind=ESMF_TYPEKIND_R4,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) i=17 count=1 call ESMF_AttributeSet(field,name="bob",value=i,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeGet(field,count=n,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) do ii=1,n call ESMF_AttributeGet(field,attributeIndex=ii,name=attname, & typekind=tk, itemcount=count, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) allocate(iptr(count)) call ESMF_AttributeGet(field, NAME=attname, itemcount=count, VALUELIST=iptr, RC=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(field2 , NAME=attname, itemcount=count, VALUELIST=iptr, RC=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) deallocate(iptr) enddo call ESMF_AttributeSet(field2,name="bob",value=i,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeGet(field2,name="bob",value=j,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((i==j), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Array to scalar" write(failMsg, *) "Did not return ESMF_SUCCESS" field3=ESMF_FieldCreate(grid,typekind=ESMF_TYPEKIND_R4,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) field4=ESMF_FieldCreate(grid,typekind=ESMF_TYPEKIND_R4,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) i=17 count=1 call ESMF_AttributeSet(field3,name="bob",value=i,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeGet(field3,count=n,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) do ii=1,n call ESMF_AttributeGet(field3,attributeIndex=ii,name=attname, & typekind=tk, itemcount=count, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) allocate(iptr(count)) call ESMF_AttributeGet(field3, NAME=attname, itemcount=count, VALUELIST=iptr, RC=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(field4 , NAME=attname, itemcount=count, VALUELIST=iptr, RC=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) deallocate(iptr) enddo call ESMF_AttributeGet(field4,name="bob",value=j,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((i==j), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Scalar from multi-valued array should error out" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_AttributeSet(field3,name="mv_array",valueList=(/ 1, 2, 3, 4, 5 /),rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeGet(field3,name="mv_array",value=j,rc=rc) if (rc==ESMF_RC_ATTR_WRONGTYPE) rc = ESMF_SUCCESS call ESMF_Test((rc==ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Default value when getting an attribute that does not exist" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_AttributeGet(field3, name="not_there", value=not_there, defaultvalue=55, & rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((not_there==55), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Multi-valued array from scalar should fail" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_AttributeSet(field3,name="a_scalar",value=999,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeGet(field3,name="a_scalar",valueList=atos,rc=rc) if (rc==ESMF_RC_ATTR_ITEMSOFF) rc = ESMF_SUCCESS call ESMF_Test((rc==ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Set array and retrieve a type R4" write(failMsg, *) "Did not return ESMF_SUCCESS" arr(1) = HUGE(arr) arr(2) = HUGE(arr) arr(3) = HUGE(arr) arr(4) = HUGE(arr) call ESMF_AttributeSet(field3,name="arr",valueList=arr,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeGet(field3,name="arr",typekind=tk,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((tk==ESMF_TYPEKIND_R4), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Set array and retrieve a type R8" write(failMsg, *) "Did not return ESMF_SUCCESS" arr2(1) = HUGE(arr2) arr2(2) = HUGE(arr2) - 2.0 call ESMF_AttributeSet(field3,name="arr2",valueList=arr2,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeGet(field3,name="arr2",typekind=tk,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((tk==ESMF_TYPEKIND_R8), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Mix R4 and R8 and return R8" write(failMsg, *) "Did not return ESMF_SUCCESS" arr2(1) = TINY(arr) arr2(2) = HUGE(arr2) ! Leave the third element uninitialized. call ESMF_AttributeSet(field3,name="arr_mix",valueList=arr2,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeGet(field3,name="arr_mix",typekind=tk,rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((tk==ESMF_TYPEKIND_R8), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Attribute copy preserves 32-bit" write(failMsg, *) "Did not return ESMF_SUCCESS" src_fb2 = ESMF_FieldBundleCreate(name="src_fb2", rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) dst_fb2 = ESMF_FieldBundleCreate(name="dst_fb2", rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(src_fb2, "is_32bit", not_there, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeCopy(src_fb2, dst_fb2, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeGet(dst_fb2, "is_32bit", typekind=actual_tk, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((actual_tk == ESMF_TYPEKIND_I4), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Attribute copy by reference preserves 32-bit" write(failMsg, *) "Did not return ESMF_SUCCESS" src_fb3 = ESMF_FieldBundleCreate(name="src_fb3", rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) dst_fb3 = ESMF_FieldBundleCreate(name="dst_fb3", rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(src_fb3, "is_32bit", actual_value, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeCopy(src_fb3, dst_fb3, attcopy=ESMF_ATTCOPY_REFERENCE, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) actual_tk = ESMF_TYPEKIND_I8 call ESMF_AttributeGet(dst_fb3, "is_32bit", typekind=actual_tk, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((actual_tk == ESMF_TYPEKIND_I4), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- !---------------------------------------------------------------------------- !NEX_UTest write(name, *) "Attribute get by index preserves 32-bit" write(failMsg, *) "Did not return ESMF_SUCCESS" fb_idx = ESMF_FieldBundleCreate(name="fb_idx", rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_AttributeSet(fb_idx, "is_32bit", actual_value, convention="NetCDF", & purpose="FV3", rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) actual_tk = ESMF_TYPEKIND_I4 call ESMF_AttributeGet(fb_idx, convention="NetCDF", purpose="FV3", & attnestflag=ESMF_ATTNEST_OFF, attributeIndex=1, & name=attname, typekind=actual_tk, itemCount=itemCount, & rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_Test((actual_tk == ESMF_TYPEKIND_I4), name, failMsg, result, ESMF_SRCLINE) ! Must abort to prevent possible hanging due to communications. if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !---------------------------------------------------------------------------- call ESMF_FieldBundleDestroy(src_fb, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_FieldBundleDestroy(dst_fb, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_FieldBundleDestroy(src_fb2, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_FieldBundleDestroy(dst_fb2, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_FieldBundleDestroy(src_fb3, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_FieldBundleDestroy(dst_fb3, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_FieldDestroy(field, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_FieldDestroy(field2, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_FieldDestroy(field3, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_FieldDestroy(field4, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_GridDestroy(grid, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) call ESMF_TestEnd(ESMF_SRCLINE) ! calls ESMF_Finalize() internally end program ESMF_AttributeUtilUTest