! $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. ! !============================================================================== program FeatureTest #include "ESMF.h" use ESMF use ESMF_TestMod use ESMF_FeatureTR15581Subr_mod implicit none integer :: rc, result character(len=ESMF_MAXSTR) :: failMsg, name real, allocatable :: a(:), b(:), c(:) integer, allocatable :: indicies(:) logical, allocatable :: tfs(:) character(8), allocatable :: strings(:) type(ESMF_AllocDType), allocatable :: dts(:) #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) character(:), allocatable :: alloc_string character(7), allocatable :: alloc_string7 character(:), allocatable :: alloc_string_array(:) character(7), allocatable :: alloc_string7_array(:) #endif type(ESMF_Logical) :: tf_c logical :: tf integer :: i integer :: memstat interface subroutine ESMC_Present_test (arg, present_val) use ESMF, only: ESMF_Logical implicit none integer, intent(in), optional :: arg type(ESMF_Logical), intent(out) :: present_val end subroutine end interface !------------------------------------------------------------------------ ! Tests for various Fortran features and implementation issues that ESMF ! depends on. result = 0 call ESMF_TestStart(ESMF_SRCLINE, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !------------------------------------------------------------------------ ! Test to ensure that NULL is used for an OPTIONAL argument when the ! argument is not present. NULL conforms to the value specified in ! Section 8.7 of Fortran TS 29113 (WG5/N1942 - 9/19/2012.) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_UTest name = "Fortran argument present in C test" failMsg = "Argument was not indicated as present when present" call ESMC_Present_test (arg=42, present_val=tf_c) tf = tf_c == ESMF_TRUE call ESMF_Test(tf, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_UTest name = "Fortran argument not present in C test" failMsg = "Argument was indicated as present when not present" call ESMC_Present_test (present_val=tf_c) tf = tf_c == ESMF_TRUE call ESMF_Test(.not. tf, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ ! Test to ensure that the F95+TR15581 (and F2003) allocatable features are supported. ! These include: ! - Allocatable derived type components ! - Allocatable dummy arguments ! - Allocatable function return values !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_UTest name = "Fortran allocatable arguments call test" failMsg = "Did not return ESMF_SUCCESS" call ESMF_FeatureAllocArg (42, a, indicies, tfs, dts, rc=rc) call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_UTest name = "Fortran allocatable arguments size test" failMsg = "Incorrect allocated size" tf = size (a) == 42 .and. size (indicies) == 42 .and. size (tfs) == 42 & .and. size (dts) == 42 rc = merge (ESMF_SUCCESS, ESMF_RC_ARG_SIZE, tf) call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) deallocate (a, indicies, tfs, dts) ! TODO: Tests are currently disabled on older compilers - e.g., pre-4.6 gfortran, ! and with Absoft, g95, and Lahey/Fujitsu due to lack of deferred-length allocatable ! character string support. Re-enable when ESMF support for these older compilers ! is no longer required. !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_UTest name = "Fortran allocatable string scalar arguments call test" failMsg = "Did not return ESMF_SUCCESS" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) call ESMF_FeatureAllocArgStr (42, & str_dllen=alloc_string, str_pilen=alloc_string7, & rc=rc) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_UTest name = "Fortran allocatable string scalar arguments len test" failMsg = "Incorrect allocated string len" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) tf = len (alloc_string) == 42 .and. len (alloc_string7) == 7 rc = merge (ESMF_SUCCESS, ESMF_RC_ARG_SIZE, tf) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) if (allocated (alloc_string)) deallocate (alloc_string) if (allocated (alloc_string7)) deallocate (alloc_string7) #endif #ifdef ESMF_TESTEXHAUSTIVE !------------------------------------------------------------------------ !------------------------------------------------------------------------ #if 0 ! TODO: Tests are currently disabled because gfortran prior to v5.1 has issues with ! arrays of deferred-length strings. Re-enable when ESMF support for these older ! compilers is no longer required. !------------------------------------------------------------------------ ! NEX_xxxUTest name = "Fortran allocatable string array arguments call test" failMsg = "Did not return ESMF_SUCCESS" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) call ESMF_FeatureAllocArgStr (42, & str_dllensize=alloc_string_array, str_pilensize=alloc_string7_array, & rc=rc) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_xxxUTest name = "Fortran allocatable string array arguments size test" failMsg = "Incorrect allocated string array size" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) tf = size (alloc_string7_array) == 42 .and. size (alloc_string_array) == 42 rc = merge (ESMF_SUCCESS, ESMF_RC_ARG_SIZE, tf) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_xxxUTest name = "Fortran allocatable string arguments len test" failMsg = "Incorrect allocated string len" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) tf = len (alloc_string_array) == 42 .and. len (alloc_string7_array) == 7 rc = merge (ESMF_SUCCESS, ESMF_RC_ARG_SIZE, tf) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) if (allocated (alloc_string_array)) deallocate (alloc_string_array) if (allocated (alloc_string7_array)) deallocate (alloc_string7_array) #endif #endif ! NOTE: Some compilers may require a special command line argument for ! the following tests to work. This is needed to turn on the F2003 ! semantics for reassignment of allocatable arrays to different sizes ! than originally allocated. For example PGI requires -Mallocatable=03 ! and Intel requires -assume realloc_lhs. ! TODO: Tests are currently disabled on older compilers - e.g., pre-4.6 gfortran, ! and with Absoft, g95, and Lahey/Fujitsu due to lack of re-allocate on ! assignment support. Re-enable when ESMF support for these older compilers ! is no longer required. #if 0 !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_xxxUTest name = "Fortran allocatable function result test" failMsg = "Did not return ESMF_SUCCESS" b = ESMF_FeatureAllocFRet (420, rc=rc) call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_xxxUTest name = "Fortran allocatable function return size test" failMsg = "Incorrect allocated size" rc = merge (ESMF_SUCCESS, ESMF_RC_ARG_SIZE, size (b) == 420) call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) print *, 'result size (b) =', size (b) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_xxxUTest name = "Fortran re-allocate existing allocatable array via assignment test" failMsg = "Incorrect allocated size" a = b rc = merge (ESMF_SUCCESS, ESMF_RC_ARG_SIZE, size (a) == 420) call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) print *, 'resized size (a) =', size (a) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! NEX_xxxUTest name = "Fortran allocate unallocated allocatable array via assignment test" failMsg = "Incorrect allocated size" c = b rc = merge (ESMF_SUCCESS, ESMF_RC_ARG_SIZE, size (c) == 420) call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) print *, 'new size (c) =', size (c) #endif !------------------------------------------------------------------------ ! F2003 allocatable deferred-length character string scalar support. !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! EX_UTest name = "Fortran allocatable deferred-length string scalar assignment test" failMsg = "Did not return correct length" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) alloc_string = '123456' rc = merge (ESMF_SUCCESS, ESMF_FAILURE, len (alloc_string) == 6) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! EX_UTest name = "Fortran allocatable deferred-length string scalar deallocate test" failMsg = "Did not return success" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) deallocate (alloc_string, stat=memstat) rc = merge (ESMF_SUCCESS, ESMF_FAILURE, memstat == 0) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! EX_UTest name = "Fortran allocatable deferred-length string scalar allocate test" failMsg = "Did not return success" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) allocate (character(len=42)::alloc_string, stat=memstat) rc = merge (ESMF_SUCCESS, ESMF_FAILURE, memstat == 0) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! EX_UTest name = "Fortran allocatable deferred-length string scalar allocate length test" failMsg = "Did not return success" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) rc = merge (ESMF_SUCCESS, ESMF_FAILURE, len (alloc_string) == 42) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) deallocate (alloc_string) #endif !------------------------------------------------------------------------ #if 0 ! TODO: Tests are currently disabled because gfortran prior to v5.1 has issues with ! arrays of deferred-length strings. Re-enable when ESMF support for these older ! compilers is no longer required. !------------------------------------------------------------------------ ! EX_xxxUTest name = "Fortran allocatable deferred-length string array assignment test" failMsg = "Did not return correct length" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) alloc_string_array = (/ '123456', '789012', '345678', '901234', '567890' /) rc = merge (ESMF_SUCCESS, ESMF_FAILURE, len (alloc_string_array) == 6) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! EX_xxxUTest name = "Fortran allocatable deferred-length string array size test" failMsg = "Did not return correct length" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) rc = merge (ESMF_SUCCESS, ESMF_FAILURE, size (alloc_string_array) == 5) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! EX_xxxUTest name = "Fortran allocatable deferred-length string array deallocate test" failMsg = "Did not return success" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) deallocate (alloc_string_array, stat=memstat) rc = merge (ESMF_SUCCESS, ESMF_FAILURE, memstat == 0) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! EX_xxxUTest name = "Fortran allocatable deferred-length string array allocate test" failMsg = "Did not return success" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) if (allocated (alloc_string_array)) deallocate (alloc_string_array) allocate (character(len=42)::alloc_string_array(24), stat=memstat) rc = merge (ESMF_SUCCESS, ESMF_FAILURE, memstat == 0) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! EX_xxxUTest name = "Fortran allocatable deferred-length string array allocate length test" failMsg = "Did not return success" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) rc = merge (ESMF_SUCCESS, ESMF_FAILURE, len (alloc_string_array) == 42) write (failMsg,*) "Expected string length of 42, returned", len (alloc_string_array) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !------------------------------------------------------------------------ ! EX_xxxUTest name = "Fortran allocatable deferred-length string array allocate size test" failMsg = "Did not return success" #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) rc = merge (ESMF_SUCCESS, ESMF_FAILURE, size (alloc_string_array) == 24) write (failMsg,*) "Expected string array size of 24, returned", size (alloc_string_array) #else name = "Bypassed " // trim (name) rc = ESMF_SUCCESS #endif call ESMF_Test(rc == ESMF_SUCCESS, name, failMsg, result, ESMF_SRCLINE) #if !defined (ESMF_NO_F2003_ALLOC_STRING_LENS) if (allocated (alloc_string_array)) deallocate (alloc_string_array) #endif !------------------------------------------------------------------------ #endif !------------------------------------------------------------------------ !------------------------------------------------------------------------ #endif call ESMF_TestEnd(ESMF_SRCLINE) end program FeatureTest