diff --git a/.github/build.oasis3-mct.ubuntu22.04 b/.github/build.oasis3-mct.ubuntu22.04 index 8c7319f64d..14256a4fed 100644 --- a/.github/build.oasis3-mct.ubuntu22.04 +++ b/.github/build.oasis3-mct.ubuntu22.04 @@ -21,7 +21,7 @@ BUILD_DIR = $(OASIS_ROOT)/util/make_dir # # # ARCHDIR : directory created when compiling -ARCHDIR = $(HOME)/.local +ARCHDIR = $(OASIS_ROOT)/install # # MPI library ((see the file /etc/modulefiles/mpi/openmpi-x86_64) MPIDIR = /usr/lib/x86_64-linux-gnu/openmpi diff --git a/.github/workflows/CI.yml b/.github/workflows/CI.yml index ee53b4fff0..fc71aa393b 100644 --- a/.github/workflows/CI.yml +++ b/.github/workflows/CI.yml @@ -14,6 +14,7 @@ jobs: runs-on: ubuntu-22.04 strategy: + fail-fast: false matrix: config: - { @@ -70,7 +71,10 @@ jobs: FC: mpifort BUILD_DIR: bld INSTALL_DIR: install - CMAKE_BUILD_PARALLEL_LEVEL: 4 + OASIS_TAG: tsmp-patches-v0.1 + OASIS_INSTALL_PREFIX: ${{ github.workspace }}/oasis3-mct/install + PFUNIT_TAG: v4.12.0 + PFUNIT_INSTALL_PREFIX: ${{ github.workspace }}/pFUnit/install steps: - uses: actions/checkout@v4 @@ -83,29 +87,75 @@ jobs: - name: Download MPI Fortran compiler run: sudo apt-get install gfortran openmpi-bin libopenmpi-dev + # + # OASIS3-MCT + # - if: matrix.config.use_oasis == 'True' - name: Cache OASIS3-MCT - uses: actions/cache@v4 - id: cache-deps - env: - cache-name: cache-eCLM-dependencies + name: Restore cached OASIS3-MCT ${{ env.OASIS_TAG }} + uses: actions/cache/restore@v4 + id: cache-oasis-restore with: - path: "~/.local" - key: cache-${{ matrix.config.name }} + path: ${{ env.OASIS_INSTALL_PREFIX }} + key: cache-${{ matrix.config.name }}-${{ env.OASIS_TAG }} - - if: matrix.config.use_oasis == 'True' && steps.cache-deps.outputs.cache-hit != 'true' - name: Install OASIS3-MCT + - if: matrix.config.use_oasis == 'True' && steps.cache-oasis-restore.outputs.cache-hit != 'true' + name: Install OASIS3-MCT ${{ env.OASIS_TAG }} + working-directory: ${{ github.workspace }} run: | - git clone https://icg4geo.icg.kfa-juelich.de/ExternalReposPublic/oasis3-mct.git + git clone -b $OASIS_TAG https://icg4geo.icg.kfa-juelich.de/ExternalReposPublic/oasis3-mct.git cd oasis3-mct export OASIS_ROOT=$(pwd) - echo "OASIS_ROOT=${OASIS_ROOT}" - echo "DEPENDENCIES_DIR=${DEPENDENCIES_DIR}" cd util/make_dir echo "include ${GITHUB_WORKSPACE}/.github/build.oasis3-mct.ubuntu22.04" > make.inc - cat make.inc make realclean static-libs -f TopMakefileOasis3 + - if: matrix.config.use_oasis == 'True' && steps.cache-oasis-restore.outputs.cache-hit != 'true' + name: Cache OASIS3-MCT ${{ env.OASIS_TAG }} + uses: actions/cache/save@v4 + with: + path: ${{ env.OASIS_INSTALL_PREFIX }} + key: cache-${{ matrix.config.name }}-${{ env.OASIS_TAG }} + + - if: matrix.config.use_oasis == 'True' + name: Add OASIS to CMAKE_PREFIX_PATH + run: | + echo "CMAKE_PREFIX_PATH=${CMAKE_PREFIX_PATH}:${OASIS_INSTALL_PREFIX}" >> $GITHUB_ENV + + # + # pFUnit + # + - name: Restore cached pFUnit ${{ env.PFUNIT_TAG }} + uses: actions/cache/restore@v4 + id: cache-pFUnit-restore + with: + path: ${{ env.PFUNIT_INSTALL_PREFIX }} + key: cache-${{ matrix.config.name }}-${{ env.PFUNIT_TAG }} + + - if: steps.cache-pFUnit-restore.outputs.cache-hit != 'true' + name: Install pFUnit ${{ env.PFUNIT_TAG }} + working-directory: ${{ github.workspace }} + run: | + git clone -b ${PFUNIT_TAG} --recursive https://github.com/Goddard-Fortran-Ecosystem/pFUnit.git + cd pFUnit + cmake -S . -B bld -DCMAKE_INSTALL_PREFIX=install + cmake --build bld + cmake --install bld + echo "CMAKE_PREFIX_PATH=${CMAKE_PREFIX_PATH}:${PFUNIT_INSTALL_PREFIX}" >> $GITHUB_ENV + + - if: steps.cache-pFUnit-restore.outputs.cache-hit != 'true' + name: Cache pFUnit ${{ env.PFUNIT_TAG }} + uses: actions/cache/save@v4 + with: + path: ${{ env.PFUNIT_INSTALL_PREFIX }} + key: cache-${{ matrix.config.name }}-${{ env.PFUNIT_TAG }} + + - name: Add pFUnit to CMAKE_PREFIX_PATH + run: | + echo "CMAKE_PREFIX_PATH=${CMAKE_PREFIX_PATH}:${PFUNIT_INSTALL_PREFIX}" >> $GITHUB_ENV + + # + # Configure, build, and install eCLM + # - name: Configure eCLM run: | cmake -S src -B $BUILD_DIR \ @@ -117,7 +167,8 @@ jobs: -DUSE_OASIS=${{ matrix.config.use_oasis }} \ -DCOUP_OAS_ICON=${{ matrix.config.coup_oas_icon }} \ -DCOUP_OAS_PFL=${{ matrix.config.coup_oas_pfl }} \ - -DUSE_PDAF=${{ matrix.config.use_pdaf }} + -DUSE_PDAF=${{ matrix.config.use_pdaf }} \ + -DENABLE_TESTS="True" - name: Build eCLM run: cmake --build $BUILD_DIR @@ -127,3 +178,19 @@ jobs: - name: Install eCLM namelist generator run: pip3 install --user ./namelist_generator + + # + # Run tests + # + - name: Run eCLM tests + id: eclm-unit-test + working-directory: ${{ env.BUILD_DIR }} + continue-on-error: true + run: | + ctest + + - name: Re-run failed eCLM tests with verbose logging + if: steps.eclm-unit-test.outcome == 'failure' + working-directory: ${{ env.BUILD_DIR }} + run: | + ctest --rerun-failed --output-on-failure diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index c2eb13fe2c..85a045eb84 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -14,6 +14,14 @@ if (USE_PDAF) set(CMAKE_Fortran_MODULE_DIRECTORY_GPTL ${CMAKE_BINARY_DIR}/externals/gptl/include) endif() +option(ENABLE_TESTS "Enable unit tests." OFF) +if (ENABLE_TESTS) + find_package(PFUNIT REQUIRED) + enable_testing() + message(STATUS "Found pFUnit v${PFUNIT_VERSION}") + message(STATUS "Unit tests enabled.") +endif() + add_subdirectory(externals) add_subdirectory(csm_share) add_subdirectory(clm5) diff --git a/src/csm_share/CMakeLists.txt b/src/csm_share/CMakeLists.txt index 42ad729297..fbb3a5cd76 100644 --- a/src/csm_share/CMakeLists.txt +++ b/src/csm_share/CMakeLists.txt @@ -132,4 +132,8 @@ if (USE_PDAF) target_compile_definitions(${PROJECT_NAME} PUBLIC USE_PDAF) endif() +if (ENABLE_TESTS) + add_subdirectory(util/test) +endif() + install (TARGETS ${PROJECT_NAME} ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR}) diff --git a/src/csm_share/esmf_wrf_timemgr/CMakeLists.txt b/src/csm_share/esmf_wrf_timemgr/CMakeLists.txt deleted file mode 100644 index d27480573c..0000000000 --- a/src/csm_share/esmf_wrf_timemgr/CMakeLists.txt +++ /dev/null @@ -1,19 +0,0 @@ -list(APPEND esmf_wrf_timemgr_sources - ESMF.F90 - ESMF_AlarmClockMod.F90 - ESMF_AlarmMod.F90 - ESMF_BaseMod.F90 - ESMF_BaseTimeMod.F90 - ESMF_CalendarMod.F90 - ESMF_ClockMod.F90 - ESMF_FractionMod.F90 - ESMF_ShrTimeMod.F90 - ESMF_Stubs.F90 - ESMF_TimeIntervalMod.F90 - ESMF_TimeMod.F90 - MeatMod.F90 - wrf_error_fatal.F90 - wrf_message.F90 - ) - -sourcelist_to_parent(esmf_wrf_timemgr_sources) \ No newline at end of file diff --git a/src/csm_share/mct/CMakeLists.txt b/src/csm_share/mct/CMakeLists.txt deleted file mode 100644 index 37bf92fb90..0000000000 --- a/src/csm_share/mct/CMakeLists.txt +++ /dev/null @@ -1,9 +0,0 @@ -list(APPEND drv_sources - glc_elevclass_mod.F90 - seq_cdata_mod.F90 - seq_comm_mct.F90 - seq_infodata_mod.F90 - seq_io_read_mod.F90 - ) - -sourcelist_to_parent(drv_sources) diff --git a/src/csm_share/util/CMakeLists.txt b/src/csm_share/util/CMakeLists.txt deleted file mode 100644 index f68be557c2..0000000000 --- a/src/csm_share/util/CMakeLists.txt +++ /dev/null @@ -1,44 +0,0 @@ -set(genf90_files shr_infnan_mod.F90.in shr_assert_mod.F90.in) - -process_genf90_source_list("${genf90_files}" ${CMAKE_CURRENT_BINARY_DIR} - share_genf90_sources) - -sourcelist_to_parent(share_genf90_sources) - -list(APPEND share_sources "${share_genf90_sources}") - -list(APPEND share_sources - shr_file_mod.F90 - shr_kind_mod.F90 - shr_const_mod.F90 - shr_sys_mod.F90 - shr_log_mod.F90 - shr_orb_mod.F90 - shr_spfn_mod.F90 - shr_strconvert_mod.F90 - shr_cal_mod.F90 - shr_nl_mod.F90 - shr_precip_mod.F90 - shr_string_mod.F90 - shr_timer_mod.F90 - shr_vmath_mod.F90 - shr_wv_sat_mod.F90) - -# Build a separate list containing the mct wrapper and its dependencies. That -# way, this list can be easily included in unit test builds that link to mct, -# but excluded from builds that do not include mct. -list(APPEND share_mct_sources - mct_mod.F90 - shr_mct_mod.F90 - shr_mpi_mod.F90 - shr_pcdf_mod.F90) - -# Build a separate list containing the pio wrapper and its dependencies. That -# way, this list can be easily included in unit test builds that include PIO or -# a stub of PIO, but excluded from builds that do not include PIO. -list(APPEND share_pio_sources - shr_pio_mod.F90) - -sourcelist_to_parent(share_sources) -sourcelist_to_parent(share_mct_sources) -sourcelist_to_parent(share_pio_sources) diff --git a/src/csm_share/util/shr_abort_mod.F90 b/src/csm_share/util/shr_abort_mod.F90 index 9e4de5bd00..8d1ba3f3a4 100644 --- a/src/csm_share/util/shr_abort_mod.F90 +++ b/src/csm_share/util/shr_abort_mod.F90 @@ -20,9 +20,6 @@ module shr_abort_mod #endif implicit none - - ! PUBLIC: Public interfaces - private ! The public routines here are only meant to be used directly by shr_sys_mod. Other code @@ -31,11 +28,42 @@ module shr_abort_mod ! when these routines were defined in shr_sys_mod.) public :: shr_abort_abort ! abort a program public :: shr_abort_backtrace ! print a backtrace, if possible - + public :: set_abort_method ! change abort method (necessary for unit testing) + public :: abort_program + + abstract interface + subroutine abort_interface(error_msg, error_code) + character(len=*) , intent(in), optional :: error_msg + integer , intent(in), optional :: error_code + end subroutine abort_interface + end interface + + procedure (abort_interface), pointer :: abort_method => null() + logical, save :: initialized = .false. contains + subroutine initialize() + abort_method => abort_program + initialized = .true. + end subroutine initialize + + subroutine set_abort_method(method) + procedure (abort_interface) :: method + if (.not. initialized) call initialize() + abort_method => method + end subroutine set_abort_method + + subroutine shr_abort_abort(error_msg, error_code) + character(len=*) , intent(in), optional :: error_msg + integer , intent(in), optional :: error_code + + if (.not. initialized) call initialize() + + call abort_method(error_msg, error_code) + end subroutine shr_abort_abort + !=============================================================================== - subroutine shr_abort_abort(string,rc) + subroutine abort_program(string,rc) ! Consistent stopping mechanism !----- arguments ----- @@ -75,7 +103,7 @@ subroutine shr_abort_abort(string,rc) ! usually sends SIGTERM to the process, and we don't catch that signal. call abort() - end subroutine shr_abort_abort + end subroutine abort_program !=============================================================================== !=============================================================================== diff --git a/src/csm_share/util/test/CMakeLists.txt b/src/csm_share/util/test/CMakeLists.txt new file mode 100644 index 0000000000..beeb607bef --- /dev/null +++ b/src/csm_share/util/test/CMakeLists.txt @@ -0,0 +1,66 @@ +# shr_abort_test +add_pfunit_ctest (csm_share_abort + TEST_SOURCES shr_abort_test/test_shr_abort.pf + OTHER_SOURCES abort_with_pfunit.F90 + LINK_LIBRARIES csm_share + EXTRA_USE abort_with_pfunit_mod + EXTRA_INITIALIZE initialize_abort +) + +# shr_assert_test +add_pfunit_ctest (csm_share_assert + TEST_SOURCES shr_assert_test/test_assert_array.pf + shr_assert_test/test_assert.pf + shr_assert_test/test_macro.pf + shr_assert_test/test_ndebug.pf + OTHER_SOURCES abort_with_pfunit.F90 + LINK_LIBRARIES csm_share + EXTRA_USE abort_with_pfunit_mod + EXTRA_INITIALIZE initialize_abort +) + +# shr_cal_test +add_pfunit_ctest (csm_share_calendar + TEST_SOURCES shr_cal_test/test_shr_cal.pf + LINK_LIBRARIES csm_share +) + +# shr_log_test +add_pfunit_ctest (csm_share_log + TEST_SOURCES shr_log_test/test_error_printers.pf + LINK_LIBRARIES csm_share +) + +# shr_precip_test +add_pfunit_ctest (csm_share_precip + TEST_SOURCES shr_precip_test/test_shr_precip.pf + LINK_LIBRARIES csm_share +) + +# shr_spfn_test +add_pfunit_ctest (csm_share_spfn + TEST_SOURCES shr_spfn_test/test_erf_r4.pf + shr_spfn_test/test_erf_r8.pf + shr_spfn_test/test_gamma_factorial.pf + shr_spfn_test/test_igamma.pf + LINK_LIBRARIES csm_share +) + +# shr_strconvert_test +add_pfunit_ctest (csm_share_strconvert + TEST_SOURCES shr_strconvert_test/test_toString.pf + LINK_LIBRARIES csm_share +) + +# shr_string_test +add_pfunit_ctest (csm_share_string + TEST_SOURCES shr_string_test/test_shr_string.pf + LINK_LIBRARIES csm_share +) + +# shr_wv_sat_test +add_pfunit_ctest (csm_share_wv_sat + TEST_SOURCES shr_wv_sat_test/test_wv_sat_each_method.pf + shr_wv_sat_test/test_wv_sat.pf + LINK_LIBRARIES csm_share +) diff --git a/src/csm_share/util/test/abort_with_pfunit.F90 b/src/csm_share/util/test/abort_with_pfunit.F90 new file mode 100644 index 0000000000..712cec5699 --- /dev/null +++ b/src/csm_share/util/test/abort_with_pfunit.F90 @@ -0,0 +1,32 @@ +module abort_with_pfunit_mod + use shr_abort_mod, only: set_abort_method + implicit none + private + + public :: abort_unit_test + public :: initialize_abort + +contains + + subroutine abort_unit_test(error_msg, error_code) + use funit, only: pFUnit_throw => throw + + character(len=*), intent(in), optional :: error_msg + integer , intent(in), optional :: error_code + + character(len=:), allocatable :: message_ + + if (present(error_msg)) then + message_ = "pFUnit test aborted: "//trim(error_msg) + else + message_ = "pFUnit test aborted." + end if + call pFUnit_throw(message_) + + end subroutine abort_unit_test + + subroutine initialize_abort() + call set_abort_method(abort_unit_test) + end subroutine initialize_abort + +end module abort_with_pfunit_mod diff --git a/src/csm_share/util/test/shr_abort_test/test_shr_abort.pf b/src/csm_share/util/test/shr_abort_test/test_shr_abort.pf new file mode 100644 index 0000000000..1bbff8d1d9 --- /dev/null +++ b/src/csm_share/util/test/shr_abort_test/test_shr_abort.pf @@ -0,0 +1,36 @@ +module test_shr_abort + + ! Tests of shr_abort_mod: version used in unit tests that + ! throws a pfunit exception rather than aborting + + use funit + use shr_sys_mod , only: shr_sys_abort + + implicit none + + @TestCase + type, extends(TestCase) :: TestShrAbort + contains + procedure :: setUp + procedure :: tearDown + end type TestShrAbort + +contains + + subroutine setUp(this) + class(TestShrAbort), intent(inout) :: this + end subroutine setUp + + subroutine tearDown(this) + class(TestShrAbort), intent(inout) :: this + end subroutine tearDown + + @Test + subroutine test_abort(this) + class(TestShrAbort), intent(inout) :: this + + call shr_abort_abort('Test message') + @assertExceptionRaised('ABORTED: Test message') + end subroutine test_abort + +end module test_shr_abort diff --git a/src/csm_share/util/test/shr_assert_test/test_assert.pf b/src/csm_share/util/test/shr_assert_test/test_assert.pf new file mode 100644 index 0000000000..c4e5544e18 --- /dev/null +++ b/src/csm_share/util/test/shr_assert_test/test_assert.pf @@ -0,0 +1,56 @@ +module test_assert + +! Test basic assert functionality. + +use funit + +use shr_assert_mod, only: & + shr_assert, & + shr_assert_all, & + shr_assert_any + +implicit none +save + +contains + +@Test +subroutine assert_can_pass() + call shr_assert(.true., "Assert unexpectedly aborted!") +end subroutine assert_can_pass + +@Test +subroutine assert_can_fail() + call shr_assert(.false., "Expected failure.") + call assertExceptionRaised("ABORTED: ERROR: Expected failure.") +end subroutine assert_can_fail + +@Test +subroutine assert_prints_file_and_line() + call shr_assert(.false., "Expected failure.", file='foo', line=42) + call assertExceptionRaised("ABORTED: ERROR in foo at line 42: Expected failure.") +end subroutine assert_prints_file_and_line + +@Test +subroutine assert_all_scalar_can_pass() + call shr_assert_all(.true., "Assert unexpectedly aborted!") +end subroutine assert_all_scalar_can_pass + +@Test +subroutine assert_all_scalar_can_fail() + call shr_assert_all(.false., "Expected failure.") + call assertExceptionRaised("ABORTED: ERROR: Expected failure.") +end subroutine assert_all_scalar_can_fail + +@Test +subroutine assert_any_scalar_can_pass() + call shr_assert_any(.true., "Assert unexpectedly aborted!") +end subroutine assert_any_scalar_can_pass + +@Test +subroutine assert_any_scalar_can_fail() + call shr_assert_any(.false., "Expected failure.") + call assertExceptionRaised("ABORTED: ERROR: Expected failure.") +end subroutine assert_any_scalar_can_fail + +end module test_assert diff --git a/src/csm_share/util/test/shr_assert_test/test_assert_array.pf b/src/csm_share/util/test/shr_assert_test/test_assert_array.pf new file mode 100644 index 0000000000..ffe8be06f2 --- /dev/null +++ b/src/csm_share/util/test/shr_assert_test/test_assert_array.pf @@ -0,0 +1,185 @@ +module test_assert_array + +! Test shr_assert_all and shr_assert_any. + +use funit + +use shr_assert_mod, only: & + shr_assert_all, & + shr_assert_any + +implicit none +save + +@TestParameter +type, extends(AbstractTestParameter) :: ArrayRank + integer :: rank + contains + procedure :: toString +end type ArrayRank + +@TestCase(testParameters={getParameters()}, constructor=new_TestAssertArray) +type, extends(ParameterizedTestCase) :: TestAssertArray + integer :: rank +end type TestAssertArray + +contains + +function new_TestAssertArray(rank) result(test) + type(ArrayRank), intent(in) :: rank + type(TestAssertArray) :: test + + test%rank = rank%rank + +end function new_TestAssertArray + +function getParameters() result(params) + type(ArrayRank), allocatable :: params(:) + + integer :: i + + params = [( ArrayRank(i), i = 1, 7 )] + +end function getParameters + +function toString(this) result(string) + class(ArrayRank), intent(in) :: this + character(:), allocatable :: string + + character(len=30) :: buffer + + write(buffer, '(A,I1,A)') "(rank = ",this%rank,")" + + string = trim(buffer) + +end function toString + +@Test +subroutine assert_all_size_zero_passes(this) + class(TestAssertArray), intent(inout) :: this + call assert_all_wrapper([logical::], 0, this%rank, & + "Assert unexpectedly aborted!") +end subroutine assert_all_size_zero_passes + +@Test +subroutine assert_all_can_pass(this) + class(TestAssertArray), intent(inout) :: this + call assert_all_wrapper([.true.], 1, this%rank, & + "Assert unexpectedly aborted!") +end subroutine assert_all_can_pass + +@Test +subroutine assert_all_can_fail(this) + class(TestAssertArray), intent(inout) :: this + call assert_all_wrapper([.false.], 1, this%rank, & + "Expected failure.") + call assertExceptionRaised("ABORTED: ERROR: Expected failure.") +end subroutine assert_all_can_fail + +@Test +subroutine assert_all_partial_false_fails(this) + class(TestAssertArray), intent(inout) :: this + logical :: test_array(2**this%rank) + integer :: i + test_array = [( mod(i,2) == 0, i = 1, size(test_array) )] + call assert_all_wrapper(test_array, 2, this%rank, & + "Expected failure.") + call assertExceptionRaised("ABORTED: ERROR: Expected failure.") +end subroutine assert_all_partial_false_fails + +@Test +subroutine assert_any_size_zero_fails(this) + class(TestAssertArray), intent(inout) :: this + call assert_any_wrapper([logical::], 0, this%rank, & + "Expected failure.") + call assertExceptionRaised("ABORTED: ERROR: Expected failure.") +end subroutine assert_any_size_zero_fails + +@Test +subroutine assert_any_can_pass(this) + class(TestAssertArray), intent(inout) :: this + call assert_any_wrapper([.true.], 1, this%rank, & + "Assert unexpectedly aborted!") +end subroutine assert_any_can_pass + +@Test +subroutine assert_any_can_fail(this) + class(TestAssertArray), intent(inout) :: this + call assert_any_wrapper([.false.], 1, this%rank, & + "Expected failure.") + call assertExceptionRaised("ABORTED: ERROR: Expected failure.") +end subroutine assert_any_can_fail + +@Test +subroutine assert_any_partial_false_passes(this) + class(TestAssertArray), intent(inout) :: this + logical :: test_array(2**this%rank) + integer :: i + test_array = [( mod(i,2) == 0, i = 1, size(test_array) )] + call assert_any_wrapper(test_array, 2, this%rank, & + "Assert unexpectedly aborted!") +end subroutine assert_any_partial_false_passes + +! The wrappers are to allow rank-generic programming. +! The routines assert with the given array and message, but the array is +! resized to have "rank" dimensions of size "dimsize". + +subroutine assert_all_wrapper(array, dimsize, rank, msg) + logical, intent(in) :: array(:) + integer, intent(in) :: dimsize + integer, intent(in) :: rank + character(len=*), intent(in) :: msg + + integer :: i + + select case (rank) + case(1) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 1)]), msg) + case(2) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 2)]), msg) + case(3) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 3)]), msg) + case(4) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 4)]), msg) + case(5) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 5)]), msg) + case(6) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 6)]), msg) + case(7) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 7)]), msg) + case default + call throw("assert_all_wrapper was given a bad rank.") + end select + +end subroutine assert_all_wrapper + +subroutine assert_any_wrapper(array, dimsize, rank, msg) + logical, intent(in) :: array(:) + integer, intent(in) :: dimsize + integer, intent(in) :: rank + character(len=*), intent(in) :: msg + + integer :: i + + select case (rank) + case(1) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 1)]), msg) + case(2) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 2)]), msg) + case(3) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 3)]), msg) + case(4) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 4)]), msg) + case(5) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 5)]), msg) + case(6) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 6)]), msg) + case(7) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 7)]), msg) + case default + call throw("assert_any_wrapper was given a bad rank.") + end select + +end subroutine assert_any_wrapper + +end module test_assert_array diff --git a/src/csm_share/util/test/shr_assert_test/test_macro.pf b/src/csm_share/util/test/shr_assert_test/test_macro.pf new file mode 100644 index 0000000000..b1626740ad --- /dev/null +++ b/src/csm_share/util/test/shr_assert_test/test_macro.pf @@ -0,0 +1,87 @@ +module test_macro + +! Test that if NDEBUG is not defined, shr_assert macros run assertions. + +use funit + +#undef NDEBUG +#include "shr_assert.h" + +contains + +@Test +subroutine macro_assert_can_pass() + SHR_ASSERT(.true., "Assert macro unexpectedly aborted!") +end subroutine macro_assert_can_pass + +@Test +subroutine macro_assert_can_fail() + SHR_ASSERT(.false., "Expected failure.") + ! When this was written, the preprocessor did not recognize this assert, + ! so call it directly instead of using an "@". + call assertExceptionRaised("ABORTED: ERROR: Expected failure.") +end subroutine macro_assert_can_fail + +@Test +subroutine macro_assert_fl() + SHR_ASSERT_FL(.false., "my_file", 42) + call assertExceptionRaised("ABORTED: ERROR in my_file at line 42") +end subroutine macro_assert_fl + +@Test +subroutine macro_assert_mfl() + SHR_ASSERT_MFL(.false., "Expected failure.", "my_file", 42) + call assertExceptionRaised("ABORTED: ERROR in my_file at line 42: Expected failure.") +end subroutine macro_assert_mfl + +@Test +subroutine macro_assert_all_can_pass() + SHR_ASSERT_ALL(([.true., .true.]), "Assert macro unexpectedly aborted!") +end subroutine macro_assert_all_can_pass + +@Test +subroutine macro_assert_all_can_fail() + SHR_ASSERT_ALL(([.true., .false.]), "Expected failure.") + ! When this was written, the preprocessor did not recognize this assert, + ! so call it directly instead of using an "@". + call assertExceptionRaised("ABORTED: ERROR: Expected failure.") +end subroutine macro_assert_all_can_fail + +@Test +subroutine macro_assert_all_fl() + SHR_ASSERT_ALL_FL(([.true., .false.]), "my_file", 42) + call assertExceptionRaised("ABORTED: ERROR in my_file at line 42") +end subroutine macro_assert_all_fl + +@Test +subroutine macro_assert_all_mfl() + SHR_ASSERT_ALL_MFL(([.true., .false.]), "Expected failure.", "my_file", 42) + call assertExceptionRaised("ABORTED: ERROR in my_file at line 42: Expected failure.") +end subroutine macro_assert_all_mfl + +@Test +subroutine macro_assert_any_can_pass() + SHR_ASSERT_ANY(([.true., .false.]), "Assert macro unexpectedly aborted!") +end subroutine macro_assert_any_can_pass + +@Test +subroutine macro_assert_any_can_fail() + SHR_ASSERT_ANY(([.false., .false.]), "Expected failure.") + ! When this was written, the preprocessor did not recognize this assert, + ! so call it directly instead of using an "@". + call assertExceptionRaised("ABORTED: ERROR: Expected failure.") +end subroutine macro_assert_any_can_fail + +@Test +subroutine macro_assert_any_fl() + SHR_ASSERT_ANY_FL(([.false., .false.]), "my_file", 42) + call assertExceptionRaised("ABORTED: ERROR in my_file at line 42") +end subroutine macro_assert_any_fl + +@Test +subroutine macro_assert_any_mfl() + SHR_ASSERT_ANY_MFL(([.false., .false.]), "Expected failure.", "my_file", 42) + call assertExceptionRaised("ABORTED: ERROR in my_file at line 42: Expected failure.") +end subroutine macro_assert_any_mfl + +end module test_macro diff --git a/src/csm_share/util/test/shr_assert_test/test_ndebug.pf b/src/csm_share/util/test/shr_assert_test/test_ndebug.pf new file mode 100644 index 0000000000..8d4d9c2a01 --- /dev/null +++ b/src/csm_share/util/test/shr_assert_test/test_ndebug.pf @@ -0,0 +1,63 @@ +module test_ndebug + +! Test that if NDEBUG is defined, shr_assert macros do nothing. + +use funit + +#define NDEBUG +#include "shr_assert.h" + +contains + + logical function unreachable_function(macro_name) + character(len=*), intent(in) :: macro_name + + call throw("NDEBUG failed to turn off " // macro_name) + end function unreachable_function + +@Test +subroutine ndebug_controls_assert_macro() + SHR_ASSERT(unreachable_function("SHR_ASSERT"), "Fake message.") +end subroutine ndebug_controls_assert_macro + +@Test +subroutine ndebug_controls_assert_fl_macro() + SHR_ASSERT_FL(unreachable_function("SHR_ASSERT_FL"), "my_file", 42) +end subroutine ndebug_controls_assert_fl_macro + +@Test +subroutine ndebug_controls_assert_mfl_macro() + SHR_ASSERT_MFL(unreachable_function("SHR_ASSERT_MFL"), "Fake message.", "my_file", 42) +end subroutine ndebug_controls_assert_mfl_macro + +@Test +subroutine ndebug_controls_assert_all_macro() + SHR_ASSERT_ALL(unreachable_function("SHR_ASSERT_ALL"), "Fake message.") +end subroutine ndebug_controls_assert_all_macro + +@Test +subroutine ndebug_controls_assert_all_fl_macro() + SHR_ASSERT_ALL_FL(unreachable_function("SHR_ASSERT_ALL_FL"), "my_file", 42) +end subroutine ndebug_controls_assert_all_fl_macro + +@Test +subroutine ndebug_controls_assert_all_mfl_macro() + SHR_ASSERT_ALL_MFL(unreachable_function("SHR_ASSERT_ALL_MFL"), "Fake message.", "my_file", 42) +end subroutine ndebug_controls_assert_all_mfl_macro + +@Test +subroutine ndebug_controls_assert_any_macro() + SHR_ASSERT_ANY(unreachable_function("SHR_ASSERT_ANY"), "Fake message.") +end subroutine ndebug_controls_assert_any_macro + +@Test +subroutine ndebug_controls_assert_any_fl_macro() + SHR_ASSERT_ANY_FL(unreachable_function("SHR_ASSERT_ANY_FL"), "my_file", 42) +end subroutine ndebug_controls_assert_any_fl_macro + +@Test +subroutine ndebug_controls_assert_any_mfl_macro() + SHR_ASSERT_ANY_MFL(unreachable_function("SHR_ASSERT_ANY_MFL"), "Fake message.", "my_file", 42) +end subroutine ndebug_controls_assert_any_mfl_macro + +end module test_ndebug diff --git a/src/csm_share/util/test/shr_cal_test/test_shr_cal.pf b/src/csm_share/util/test/shr_cal_test/test_shr_cal.pf new file mode 100644 index 0000000000..fff7278685 --- /dev/null +++ b/src/csm_share/util/test/shr_cal_test/test_shr_cal.pf @@ -0,0 +1,396 @@ +module test_shr_cal + + ! Tests of shr_cal_mod + + use funit + use shr_cal_mod + use shr_kind_mod , only : r8 => shr_kind_r8, i4 => shr_kind_in, i8 => shr_kind_i8 + use esmf, only : ESMF_Initialize, ESMF_Finalize, ESMF_Time, ESMF_TimeSet + use esmf, only : ESMF_CALKIND_GREGORIAN + + implicit none + + @TestCase + type, extends(TestCase) :: TestShrCal + contains + procedure :: setUp + procedure :: tearDown + end type TestShrCal + + real(r8), parameter :: tol = 1.e-13_r8 + +contains + + subroutine setUp(this) + class(TestShrCal), intent(inout) :: this + + call ESMF_Initialize() + end subroutine setUp + + subroutine tearDown(this) + class(TestShrCal), intent(inout) :: this + + call ESMF_Finalize() + end subroutine tearDown + + ! ------------------------------------------------------------------------ + ! Tests of shr_cal_date2ymd + ! ------------------------------------------------------------------------ + + @Test + subroutine date2ymd_int_basic(this) + class(TestShrCal), intent(inout) :: this + integer(i4) :: date, year, month, day + + date = 98760317 + call shr_cal_date2ymd(date, year, month, day) + @assertEqual(9876, year) + @assertEqual(3, month) + @assertEqual(17, day) + end subroutine date2ymd_int_basic + + @Test + subroutine date2ymd_long_basic(this) + class(TestShrCal), intent(inout) :: this + integer(i8) :: date + integer(i4) :: year, month, day + + date = 9876540317_i8 + call shr_cal_date2ymd(date, year, month, day) + @assertEqual(987654, year) + @assertEqual(3, month) + @assertEqual(17, day) + end subroutine date2ymd_long_basic + + ! ------------------------------------------------------------------------ + ! Tests of shr_cal_date2julian + ! ------------------------------------------------------------------------ + + @Test + subroutine date2julian_int_basic(this) + class(TestShrCal), intent(inout) :: this + integer(i4) :: date, sec + real(r8) :: jday + real(r8) :: expected + + date = 98760317 + sec = 86400/2 + call shr_cal_date2julian(date = date, sec = sec, jday = jday, calendar = 'noleap') + + expected = 31._r8 + 28._r8 + 17._r8 + 0.5_r8 + @assertEqual(expected, jday) + end subroutine date2julian_int_basic + + @Test + subroutine date2julian_long_basic(this) + class(TestShrCal), intent(inout) :: this + integer(i8) :: date + integer(i4) :: sec + real(r8) :: jday + real(r8) :: expected + + date = 9876540317_i8 + sec = 86400/2 + call shr_cal_date2julian(date = date, sec = sec, jday = jday, calendar = 'noleap') + + expected = 31._r8 + 28._r8 + 17._r8 + 0.5_r8 + @assertEqual(expected, jday) + end subroutine date2julian_long_basic + + ! ------------------------------------------------------------------------ + ! Tests of shr_cal_ymd2date + ! ------------------------------------------------------------------------ + + @Test + subroutine ymd2date_int_basic(this) + class(TestShrCal), intent(inout) :: this + integer(i4) :: date + + call shr_cal_ymd2date(year=9876, month=3, day=17, date=date) + @assertEqual(98760317, date) + end subroutine ymd2date_int_basic + + @Test + subroutine ymd2date_long_basic(this) + class(TestShrCal), intent(inout) :: this + integer(i8) :: date + + call shr_cal_ymd2date(year=987654, month=3, day=17, date=date) + @assertEqual(9876540317_i8, date) + end subroutine ymd2date_long_basic + + ! ------------------------------------------------------------------------ + ! Tests of shr_cal_advDate + ! ------------------------------------------------------------------------ + + @Test + subroutine advDate_int_1dayPlus1sec(this) + class(TestShrCal), intent(inout) :: this + integer(i4) :: date_in, date_out + real(r8) :: sec_in, sec_out + + date_in = 98760317 + sec_in = 100._r8 + call shr_cal_advDate(delta = 86401._r8, units = 'seconds', & + dateIN = date_in, secIN = sec_in, & + dateOUT = date_out, secOUT = sec_out, & + calendar = 'noleap') + + @assertEqual(98760318, date_out) + @assertEqual(101._r8, sec_out, tolerance=tol) + end subroutine advDate_int_1dayPlus1sec + + @Test + subroutine advDate_int_minus1dayMinus1sec(this) + class(TestShrCal), intent(inout) :: this + integer(i4) :: date_in, date_out + real(r8) :: sec_in, sec_out + + date_in = 98760317 + sec_in = 100._r8 + call shr_cal_advDate(delta = -86401._r8, units = 'seconds', & + dateIN = date_in, secIN = sec_in, & + dateOUT = date_out, secOUT = sec_out, & + calendar = 'noleap') + + @assertEqual(98760316, date_out) + @assertEqual(99._r8, sec_out, tolerance=tol) + end subroutine advDate_int_minus1dayMinus1sec + + @Test + subroutine advDate_long_1dayPlus1sec(this) + class(TestShrCal), intent(inout) :: this + integer(i8) :: date_in, date_out + real(r8) :: sec_in, sec_out + + date_in = 9876540317_i8 + sec_in = 100._r8 + call shr_cal_advDate(delta = 86401._r8, units = 'seconds', & + dateIN = date_in, secIN = sec_in, & + dateOUT = date_out, secOUT = sec_out, & + calendar = 'noleap') + + @assertEqual(9876540318_i8, date_out) + @assertEqual(101._r8, sec_out, tolerance=tol) + end subroutine advDate_long_1dayPlus1sec + + @Test + subroutine advDate_long_minus1dayMinus1sec(this) + class(TestShrCal), intent(inout) :: this + integer(i8) :: date_in, date_out + real(r8) :: sec_in, sec_out + + date_in = 9876540317_i8 + sec_in = 100._r8 + call shr_cal_advDate(delta = -86401._r8, units = 'seconds', & + dateIN = date_in, secIN = sec_in, & + dateOUT = date_out, secOUT = sec_out, & + calendar = 'noleap') + + @assertEqual(9876540316_i8, date_out) + @assertEqual(99._r8, sec_out, tolerance=tol) + end subroutine advDate_long_minus1dayMinus1sec + + ! ------------------------------------------------------------------------ + ! Tests of shr_cal_advDateInt + ! ------------------------------------------------------------------------ + + @Test + subroutine advDateInt_int_1dayPlus1sec(this) + class(TestShrCal), intent(inout) :: this + integer(i4) :: date_in, date_out + integer(i4) :: sec_in, sec_out + + date_in = 98760317 + sec_in = 100 + call shr_cal_advDateInt(delta = 86401, units = 'seconds', & + dateIN = date_in, secIN = sec_in, & + dateOUT = date_out, secOUT = sec_out, & + calendar = 'noleap') + + @assertEqual(98760318, date_out) + @assertEqual(101, sec_out) + end subroutine advDateInt_int_1dayPlus1sec + + @Test + subroutine advDateInt_int_minus1dayMinus1sec(this) + class(TestShrCal), intent(inout) :: this + integer(i4) :: date_in, date_out + integer(i4) :: sec_in, sec_out + + date_in = 98760317 + sec_in = 100 + call shr_cal_advDateInt(delta = -86401, units = 'seconds', & + dateIN = date_in, secIN = sec_in, & + dateOUT = date_out, secOUT = sec_out, & + calendar = 'noleap') + + @assertEqual(98760316, date_out) + @assertEqual(99, sec_out) + end subroutine advDateInt_int_minus1dayMinus1sec + + @Test + subroutine advDateInt_long_1dayPlus1sec(this) + class(TestShrCal), intent(inout) :: this + integer(i8) :: date_in, date_out + integer(i4) :: sec_in, sec_out + + date_in = 9876540317_i8 + sec_in = 100 + call shr_cal_advDateInt(delta = 86401, units = 'seconds', & + dateIN = date_in, secIN = sec_in, & + dateOUT = date_out, secOUT = sec_out, & + calendar = 'noleap') + + @assertEqual(9876540318_i8, date_out) + @assertEqual(101, sec_out) + end subroutine advDateInt_long_1dayPlus1sec + + @Test + subroutine advDateInt_long_minus1dayMinus1sec(this) + class(TestShrCal), intent(inout) :: this + integer(i8) :: date_in, date_out + integer(i4) :: sec_in, sec_out + + date_in = 9876540317_i8 + sec_in = 100 + call shr_cal_advDateInt(delta = -86401, units = 'seconds', & + dateIN = date_in, secIN = sec_in, & + dateOUT = date_out, secOUT = sec_out, & + calendar = 'noleap') + + @assertEqual(9876540316_i8, date_out) + @assertEqual(99, sec_out) + end subroutine advDateInt_long_minus1dayMinus1sec + + ! ------------------------------------------------------------------------ + ! Tests of shr_cal_ymdtod2string + ! ------------------------------------------------------------------------ + + @Test + subroutine ymdtod2string_smallYear(this) + class(TestShrCal), intent(inout) :: this + character(len=18) :: date_str + + call shr_cal_ymdtod2string(date_str, yy=123, mm=4, dd=5, tod=6789) + @assertEqual('0123-04-05-06789', date_str) + end subroutine ymdtod2string_smallYear + + @Test + subroutine ymdtod2string_largeYear(this) + class(TestShrCal), intent(inout) :: this + character(len=18) :: date_str + + call shr_cal_ymdtod2string(date_str, yy=123456, mm=4, dd=5, tod=6789) + @assertEqual('123456-04-05-06789', date_str) + end subroutine ymdtod2string_largeYear + + @Test + subroutine ymdtod2string_noTOD(this) + class(TestShrCal), intent(inout) :: this + character(len=18) :: date_str + + call shr_cal_ymdtod2string(date_str, yy=123, mm=4, dd=5) + @assertEqual('0123-04-05', date_str) + end subroutine ymdtod2string_noTOD + + @Test + subroutine ymdtod2string_noDay(this) + class(TestShrCal), intent(inout) :: this + character(len=18) :: date_str + + call shr_cal_ymdtod2string(date_str, yy=123, mm=4) + @assertEqual('0123-04', date_str) + end subroutine ymdtod2string_noDay + + @Test + subroutine ymdtod2string_noMonth(this) + class(TestShrCal), intent(inout) :: this + character(len=18) :: date_str + + call shr_cal_ymdtod2string(date_str, yy=123) + @assertEqual('0123', date_str) + end subroutine ymdtod2string_noMonth + + @Test + subroutine ymdtod2string_yearTooLarge(this) + class(TestShrCal), intent(inout) :: this + character(len=18) :: date_str + + call shr_cal_ymdtod2string(date_str, yy=1234567, mm=4, dd=5) + @assertExceptionRaised('ABORTED: shr_cal_ymdtod2string : year too large (max of 999999)') + end subroutine ymdtod2string_yearTooLarge + + @Test + subroutine ymdtod2string_stringTooShort(this) + class(TestShrCal), intent(inout) :: this + character(len=17) :: date_str + + call shr_cal_ymdtod2string(date_str, yy=123456, mm=4, dd=5, tod=6789) + @assertExceptionRaised('ABORTED: shr_cal_ymdtod2string : output string too short') + end subroutine ymdtod2string_stringTooShort + + @Test + subroutine ymdtod2string_stringTooShort_noTOD(this) + class(TestShrCal), intent(inout) :: this + character(len=11) :: date_str + + call shr_cal_ymdtod2string(date_str, yy=123456, mm=4, dd=5) + @assertExceptionRaised('ABORTED: shr_cal_ymdtod2string : output string too short') + end subroutine ymdtod2string_stringTooShort_noTOD + + ! ------------------------------------------------------------------------ + ! Tests of shr_cal_datetod2string + ! ------------------------------------------------------------------------ + + @Test + subroutine datetod2string_int_basic(this) + class(TestShrCal), intent(inout) :: this + character(len=18) :: date_str + + call shr_cal_datetod2string(date_str = date_str, ymd = 1230405, tod = 6789) + @assertEqual('0123-04-05-06789', date_str) + end subroutine datetod2string_int_basic + + @Test + subroutine datetod2string_long_basic(this) + class(TestShrCal), intent(inout) :: this + character(len=18) :: date_str + + call shr_cal_datetod2string(date_str = date_str, ymd = 9876540405_i8, tod = 6789) + @assertEqual('987654-04-05-06789', date_str) + end subroutine datetod2string_long_basic + + ! ------------------------------------------------------------------------ + ! Tests of shr_cal_ymds2rday_offset + ! ------------------------------------------------------------------------ + + @Test + subroutine ymds2rdayOffset_basic(this) + class(TestShrCal), intent(inout) :: this + type(ESMF_Time) :: etime + real(r8) :: rdays_offset + real(r8) :: expected + + ! Most of the current time settings here are arbitrary. However, the year and month + ! are important. + call ESMF_TimeSet(etime, yy=2000, mm=4, dd=15, h=1, m=5, s=30, & + calkindflag = ESMF_CALKIND_GREGORIAN) + + call shr_cal_ymds2rday_offset(etime=etime, & + rdays_offset = rdays_offset, & + years_offset = -1, & + months_offset = -1, & + days_offset = -2, & + seconds_offset = -21600) + + expected = -366._r8 & ! -1 year, since year-2000 is a leap year + - 31._r8 & ! -1 month, since starting month is April + - 2._r8 & ! -2 days + - 0.25_r8 ! -21600 seconds = -0.25 days + + @assertEqual(expected, rdays_offset, tolerance=tol) + + end subroutine ymds2rdayOffset_basic + +end module test_shr_cal diff --git a/src/csm_share/util/test/shr_infnan_test/test_infnan.F90 b/src/csm_share/util/test/shr_infnan_test/test_infnan.F90 new file mode 100644 index 0000000000..01123ee239 --- /dev/null +++ b/src/csm_share/util/test/shr_infnan_test/test_infnan.F90 @@ -0,0 +1,174 @@ +program test_infnan + +! +! This is a test for the shr_infnan_mod module. It was created using the +! pre-CTest system, with minimal changes to keep it working. So it may not +! be a great example of a CTest test now. +! + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_kind_mod, only: r4 => shr_kind_r4 +use shr_kind_mod, only: i8 => shr_kind_i8 +use shr_kind_mod, only: i4 => shr_kind_i4 +use, intrinsic :: ieee_exceptions, only : ieee_status_type, ieee_get_status, ieee_set_status +use, intrinsic :: ieee_exceptions, only : ieee_set_halting_mode +use, intrinsic :: ieee_exceptions, only : ieee_invalid, ieee_divide_by_zero +use shr_infnan_mod + +implicit none + +type(ieee_status_type) :: status_value +real(r8) :: x, zero +real(r4) :: y +real(r8) :: r8array(100), r82Darray(10,10), r83Darray(4,4,4) +real(r8) :: r84Darray(3,3,3,3), r85Darray(2,2,2,2,2) +real(r8) :: inf +real(r8) :: nan +real(r8) :: nans +real(r4) :: spnan +real(r4) :: spnans +integer(i8), parameter :: dpinfpat = int(O'0777600000000000000000',i8) +integer(i8), parameter :: dpnanpat = int(O'0777700000000000000000',i8) +integer(i8), parameter :: dpnanspat = int(O'0777610000000000000000',i8) +integer(i4), parameter :: spnanpat = int(Z'7FC00000',i4) +integer(i4), parameter :: spnanspat = int(Z'7FC10000',i4) +intrinsic :: count + +! Get initial ieee status so we can restore it later +call ieee_get_status(status_value) + +! Need to turn off ieee_invalid checks for some of these tests to pass +call ieee_set_halting_mode([ieee_invalid, ieee_divide_by_zero], .false.) + +inf = transfer(dpinfpat,inf) +nan = transfer(dpnanpat,nan) +nans = transfer(dpnanspat,nans) +spnan = transfer( spnanpat,spnan) +spnans = transfer( spnanspat,spnans) + +x = 0.0 +zero = 0.0 + +call assert( shr_infnan_isnan( nan ), "Test that value set to nan is nan" ) +call assert( shr_infnan_isnan( nans ), "Test that value set to nans is nan" ) +call assert( shr_infnan_isnan( spnan ), "Test that value set to sp nan is nan" ) +call assert( shr_infnan_isnan( spnans ), "Test that value set to sp nans is nan" ) +call assert( .not. shr_infnan_isnan( 1.0_r8 ), "Test that value set to one is NOT nan" ) +call assert( .not. shr_infnan_isnan( 1.0_r4 ), "Test that value set to SP one is NOT nan" ) +call assert( .not. shr_infnan_isnan( huge(x) ), "Test that value set to huge is NOT nan" ) +x = 1.0/zero +call assert( .not. shr_infnan_isnan( x ), "Test that 1/0 is NOT nan" ) +x = -1.0/zero +call assert( .not. shr_infnan_isnan( x ), "Test that -1/0 is NOT nan" ) + +r8array(:) = 1.0d00 +r8array(10) = nan +r8array(15) = nan +r82Darray(:,:) = 1.0d00 +r82Darray(5,5) = nan +r82Darray(10,7) = nan +r82Darray(7,9) = nan +r83Darray(:,:,:) = 1.0d00 +r83Darray(4,2,2) = nan +r83Darray(3,1,2) = nan +r83Darray(1,1,1) = nan +r83Darray(1,1,4) = nan +r84Darray(:,:,:,:) = 1.0d00 +r84Darray(3,2,2,1) = nan +r84Darray(3,1,2,1) = nan +r84Darray(1,1,1,1) = nan +r84Darray(1,1,3,1) = nan +r84Darray(1,2,3,1) = nan +r85Darray(:,:,:,:,:) = 1.0d00 +r85Darray(1,2,2,1,1) = nan +r85Darray(1,1,2,1,2) = nan +r85Darray(1,1,1,2,1) = nan +r85Darray(1,2,2,2,1) = nan +r85Darray(1,2,1,1,2) = nan +r85Darray(1,1,1,1,1) = nan +call assert( any(shr_infnan_isnan( r8array )), "Test that array with 2 nans is nan" ) +call assert( count(shr_infnan_isnan( r8array )) == 2, "Test that there are 2 nans in that array" ) +call assert( any(shr_infnan_isnan( r82Darray )), "Test that 2D array with 3 nans is nan" ) +call assert( count(shr_infnan_isnan( r82Darray )) == 3, "Test that there are 3 nans in that array" ) +call assert( any(shr_infnan_isnan( r83Darray )), "Test that 3D array with 4 nans is nan" ) +call assert( count(shr_infnan_isnan( r83Darray )) == 4, "Test that there are 4 nans in that array" ) +call assert( any(shr_infnan_isnan( r84Darray )), "Test that 4D array with 5 nans is nan" ) +call assert( count(shr_infnan_isnan( r84Darray )) == 5, "Test that there are 5 nans in that array" ) +call assert( any(shr_infnan_isnan( r85Darray )), "Test that 5D array with 6 nans is nan" ) +call assert( count(shr_infnan_isnan( r85Darray )) == 6, "Test that there are 6 nans in that array" ) +call assert( shr_infnan_isposinf( inf ), "Test that value set to inf is inf" ) +call assert( .not. shr_infnan_isposinf( 1.0_r8 ), "Test that value set to one is NOT inf" ) +call assert( .not. shr_infnan_isposinf( 1.0_r4 ), "Test that value set to SP one is NOT inf" ) +call assert( shr_infnan_isneginf( -inf ), "Test that value set to -inf is -inf" ) +call assert( .not. shr_infnan_isneginf( 1.0_r8 ), "Test that value set to one is NOT -inf" ) +call assert( .not. shr_infnan_isneginf( 1.0_r4 ), "Test that value set to SP one is NOT -inf" ) +x = 1.0/zero +call assert( shr_infnan_isposinf( x ), "Test that 1/0 is inf" ) +x = -1.0/zero +call assert( shr_infnan_isneginf( x ), "Test that -1/0 is -inf" ) + +x = -1.0 +call assert( shr_infnan_isnan( sqrt(x) ), "Test that sqrt-1 is nan" ) +call assert( shr_infnan_isnan( log(x) ), "Test that log-1 is nan" ) + +x = shr_infnan_nan +call assert( shr_infnan_isnan( x ), "Test that shr_infnan_nan sets r8 to nan" ) +y = shr_infnan_nan +call assert( shr_infnan_isnan( y ), "Test that shr_infnan_nan sets r4 to nan" ) + +x = shr_infnan_inf +call assert( shr_infnan_isinf( x ), "Test that shr_infnan_inf sets r8 to inf" ) +y = shr_infnan_inf +call assert( shr_infnan_isinf( y ), "Test that shr_infnan_inf sets r4 to inf" ) + +x = shr_infnan_posinf +call assert( shr_infnan_isposinf( x ), "Test that shr_infnan_posinf sets r8 to +inf" ) +y = shr_infnan_posinf +call assert( shr_infnan_isposinf( y ), "Test that shr_infnan_posinf sets r4 to +inf" ) + +x = shr_infnan_neginf +call assert( shr_infnan_isneginf( x ), "Test that shr_infnan_neginf sets r8 to -inf" ) +y = shr_infnan_neginf +call assert( shr_infnan_isneginf( y ), "Test that shr_infnan_neginf sets r4 to -inf" ) + +x = shr_infnan_to_r8(shr_infnan_qnan) +call assert( shr_infnan_isnan( x ), "Test that shr_infnan_to_r8(shr_infnan_qnan) sets r8 to nan" ) +y = shr_infnan_to_r4(shr_infnan_qnan) +call assert( shr_infnan_isnan( y ), "Test that shr_infnan_to_r4(shr_infnan_qnan) sets r4 to nan" ) + +x = shr_infnan_to_r8(shr_infnan_snan) +call assert( shr_infnan_isnan( x ), "Test that shr_infnan_to_r8(shr_infnan_snan) sets r8 to nan" ) +y = shr_infnan_to_r4(shr_infnan_snan) +call assert( shr_infnan_isnan( y ), "Test that shr_infnan_to_r4(shr_infnan_snan) sets r4 to nan" ) + +x = shr_infnan_to_r8(shr_infnan_posinf) +call assert( shr_infnan_isposinf( x ), "Test that shr_infnan_to_r8(shr_infnan_posinf) sets r8 to +inf" ) +y = shr_infnan_to_r4(shr_infnan_posinf) +call assert( shr_infnan_isposinf( y ), "Test that shr_infnan_to_r4(shr_infnan_posinf) sets r4 to +inf" ) + +x = shr_infnan_to_r8(shr_infnan_neginf) +call assert( shr_infnan_isneginf( x ), "Test that shr_infnan_to_r8(shr_infnan_neginf) sets r8 to -inf" ) +y = shr_infnan_to_r4(shr_infnan_neginf) +call assert( shr_infnan_isneginf( y ), "Test that shr_infnan_to_r4(shr_infnan_neginf) sets r4 to -inf" ) + +! Restore original status +! +! At least with gfortran, this restoration prevents floating point exceptions from being +! raised at the end of the run. Alternatively, we could probably set various flags to +! .false., using ieee_set_flag. +call ieee_set_status(status_value) + +contains + + subroutine assert(val, msg) + logical, intent(in) :: val + character(len=*), intent(in) :: msg + + if (.not. val) then + print *, msg + stop 1 + end if + + end subroutine assert + +end program test_infnan diff --git a/src/csm_share/util/test/shr_log_test/test_error_printers.pf b/src/csm_share/util/test/shr_log_test/test_error_printers.pf new file mode 100644 index 0000000000..1fc2b97273 --- /dev/null +++ b/src/csm_share/util/test/shr_log_test/test_error_printers.pf @@ -0,0 +1,51 @@ +module test_error_printers + +use funit + +! Tests for routines that create error messages. We obviously can't automate the +! process of deciding whether a message is correct or helpful, but we can test +! that the information provided is actually put into the output. + +use shr_kind_mod, only: cx => shr_kind_cx + +use shr_strconvert_mod, only: toString + +implicit none + +contains + +@Test +subroutine errMsg_prints_arguments() + use shr_log_mod, only: shr_log_errMsg + + character(len=*), parameter :: file_name = "foo.F90" + integer, parameter :: line_no = 20 + + character(len=cx) :: error_string + + error_string = shr_log_errMsg(file_name, line_no) + + @assertLessThan(0, index(error_string, file_name)) + @assertLessThan(0, index(error_string, toString(line_no))) + +end subroutine errMsg_prints_arguments + +@Test +subroutine OOBMsg_prints_arguments() + use shr_log_mod, only: shr_log_OOBMsg + + character(len=*), parameter :: operation = "foo" + integer, parameter :: bounds(2) = [2, 3], idx = 5 + + character(len=cx) :: error_string + + error_string = shr_log_OOBMsg(operation, bounds, idx) + + @assertLessThan(0, index(error_string, operation)) + @assertLessThan(0, index(error_string, toString(bounds(1)))) + @assertLessThan(0, index(error_string, toString(bounds(2)))) + @assertLessThan(0, index(error_string, toString(idx))) + +end subroutine OOBMsg_prints_arguments + +end module test_error_printers diff --git a/src/csm_share/util/test/shr_precip_test/test_shr_precip.pf b/src/csm_share/util/test/shr_precip_test/test_shr_precip.pf new file mode 100644 index 0000000000..5a93bf0c43 --- /dev/null +++ b/src/csm_share/util/test/shr_precip_test/test_shr_precip.pf @@ -0,0 +1,62 @@ +module test_shr_precip + + ! Tests of shr_precip_mod + + use funit + use shr_precip_mod + use shr_kind_mod, only : r8 => SHR_KIND_R8 + use shr_const_mod, only : SHR_CONST_TKFRZ + + implicit none + + @TestCase + type, extends(TestCase) :: TestShrPrecip + contains + procedure :: setUp + procedure :: tearDown + end type TestShrPrecip + + real(r8), parameter :: tol = 1.e-13_r8 + +contains + + subroutine setUp(this) + class(TestShrPrecip), intent(inout) :: this + end subroutine setUp + + subroutine tearDown(this) + class(TestShrPrecip), intent(inout) :: this + end subroutine tearDown + + ! ------------------------------------------------------------------------ + ! Tests of shr_precip_partition_rain_snow_ramp + ! ------------------------------------------------------------------------ + + @Test + subroutine partition_rain_snow_ramp_allSnow(this) + class(TestShrPrecip), intent(inout) :: this + real(r8) :: frac_rain + + call shr_precip_partition_rain_snow_ramp(273._r8, frac_rain) + @assertEqual(0._r8, frac_rain) + end subroutine partition_rain_snow_ramp_allSnow + + @Test + subroutine partition_rain_snow_ramp_allRain(this) + class(TestShrPrecip), intent(inout) :: this + real(r8) :: frac_rain + + call shr_precip_partition_rain_snow_ramp(276._r8, frac_rain) + @assertEqual(1._r8, frac_rain) + end subroutine partition_rain_snow_ramp_allRain + + @Test + subroutine partition_rain_snow_ramp_mixture(this) + class(TestShrPrecip), intent(inout) :: this + real(r8) :: frac_rain + + call shr_precip_partition_rain_snow_ramp(SHR_CONST_TKFRZ + 1.5_r8, frac_rain) + @assertEqual(0.75_r8, frac_rain, tolerance=tol) + end subroutine partition_rain_snow_ramp_mixture + +end module test_shr_precip diff --git a/src/csm_share/util/test/shr_spfn_test/test_erf_r4.pf b/src/csm_share/util/test/shr_spfn_test/test_erf_r4.pf new file mode 100644 index 0000000000..9069006105 --- /dev/null +++ b/src/csm_share/util/test/shr_spfn_test/test_erf_r4.pf @@ -0,0 +1,132 @@ +module test_erf_r4 + +use funit + +use shr_kind_mod, only: & + r4 => shr_kind_r4 + +use shr_spfn_mod, only: & + erf => shr_spfn_erf, & + erfc => shr_spfn_erfc, & + erfc_scaled => shr_spfn_erfc_scaled + +implicit none +save + +! Approximately what (negative) number makes erfc_scaled overflow? +real(r4), parameter :: erfc_scaled_overflow = 9._r4 + +@TestParameter +type, extends(AbstractTestParameter) :: ErfR4Params + real(r4) :: test_point + real(r4) :: erf_val + real(r4) :: tol = 0._r4 + contains + procedure :: toString +end type ErfR4Params + +@TestCase(testParameters={getParameters()}, constructor=new_TestErfR4) +type, extends(ParameterizedTestCase) :: TestErfR4 + real(r4) :: test_point + real(r4) :: erf_val + real(r4) :: tol +end type TestErfR4 + +contains + +function new_TestErfR4(params) result(test) + type(ErfR4Params), intent(in) :: params + type(TestErfR4) :: test + + test%test_point = params%test_point + test%erf_val = params%erf_val + test%tol = params%tol + +end function new_TestErfR4 + +function getParameters() result(params) + type(ErfR4Params), allocatable :: params(:) + + params = [ & + ErfR4Params(0._r4, 0._r4), & + ErfR4Params(15._r4, 1._r4), & + ErfR4Params(-15._r4, -1._r4), & + ErfR4Params(1._r4, 0.842700792949714869341, tol=1.e-5_r4), & + ErfR4Params(-1._r4, -0.842700792949714869341, tol=1.e-5_r4) ] + +end function getParameters + +function toString(this) result(string) + class(ErfR4Params), intent(in) :: this + character(:), allocatable :: string + + character(len=80) :: buffer + + write(buffer, '(A,F8.4,A,F8.4,A)') & + "(point = ",this%test_point,", erf = ",this%erf_val,")" + + string = trim(buffer) + +end function toString + +! Check that the erf function gets the expected result. +@Test +subroutine erf_r4_has_correct_value(this) + class(TestErfR4), intent(inout) :: this + @assertEqual(this%erf_val, erf(this%test_point), tolerance=this%tol) +end subroutine erf_r4_has_correct_value + +! Check that two runs of the erf function get identical results. +@Test +subroutine erf_r4_is_reproducible(this) + class(TestErfR4), intent(inout) :: this + @assertEqual(erf(this%test_point), erf(this%test_point)) +end subroutine erf_r4_is_reproducible + +! Check that erfc(x) = 1 - erf(x). +@Test +subroutine erfc_r4_has_correct_value(this) + class(TestErfR4), intent(inout) :: this + @assertEqual(1._r4 - this%erf_val, erfc(this%test_point), tolerance=this%tol) +end subroutine erfc_r4_has_correct_value + +! Check that two runs of the erfc function get identical results. +@Test +subroutine erfc_r4_is_reproducible(this) + class(TestErfR4), intent(inout) :: this + @assertEqual(erfc(this%test_point), erfc(this%test_point)) +end subroutine erfc_r4_is_reproducible + +! Check that erfc_scaled(x) = exp(x**2) * (1 - erf(x)). +@Test +subroutine erfc_scaled_r4_has_correct_value(this) + class(TestErfR4), intent(inout) :: this + real(r4) :: erfc_scaled_expected + + ! Distinguish between where the test point has a modest value, or is too + ! big to use a naive calculation. + if (abs(this%test_point) < erfc_scaled_overflow) then + erfc_scaled_expected = exp(this%test_point**2)*(1._r4 - this%erf_val) + else + ! For larger positive values, we could use an approximation, but this + ! is not trivial. Large negative values should overflow; the only + ! thing we could possibly check in that case would be to ensure that + ! the implementation throws a floating-point error. + + ! For now, just automatically pass the test for large values. + return + end if + + @assertEqual(erfc_scaled_expected, erfc_scaled(this%test_point), tolerance=this%tol) +end subroutine erfc_scaled_r4_has_correct_value + +! Check that two runs of the erfc_scaled function get identical results. +@Test +subroutine erfc_scaled_r4_is_reproducible(this) + class(TestErfR4), intent(inout) :: this + ! Skip this if we overflow. + if (this%test_point < -erfc_scaled_overflow) return + @assertEqual(erfc_scaled(this%test_point), erfc_scaled(this%test_point)) +end subroutine erfc_scaled_r4_is_reproducible + +end module test_erf_r4 diff --git a/src/csm_share/util/test/shr_spfn_test/test_erf_r8.pf b/src/csm_share/util/test/shr_spfn_test/test_erf_r8.pf new file mode 100644 index 0000000000..8f5dd366be --- /dev/null +++ b/src/csm_share/util/test/shr_spfn_test/test_erf_r8.pf @@ -0,0 +1,132 @@ +module test_erf_r8 + +use funit + +use shr_kind_mod, only: & + r8 => shr_kind_r8 + +use shr_spfn_mod, only: & + erf => shr_spfn_erf, & + erfc => shr_spfn_erfc, & + erfc_scaled => shr_spfn_erfc_scaled + +implicit none +save + +! Approximately what (negative) number makes erfc_scaled overflow? +real(r8), parameter :: erfc_scaled_overflow = 26._r8 + +@TestParameter +type, extends(AbstractTestParameter) :: ErfR8Params + real(r8) :: test_point + real(r8) :: erf_val + real(r8) :: tol = 0._r8 + contains + procedure :: toString +end type ErfR8Params + +@TestCase(testParameters={getParameters()}, constructor=new_TestErfR8) +type, extends(ParameterizedTestCase) :: TestErfR8 + real(r8) :: test_point + real(r8) :: erf_val + real(r8) :: tol +end type TestErfR8 + +contains + +function new_TestErfR8(params) result(test) + type(ErfR8Params), intent(in) :: params + type(TestErfR8) :: test + + test%test_point = params%test_point + test%erf_val = params%erf_val + test%tol = params%tol + +end function new_TestErfR8 + +function getParameters() result(params) + type(ErfR8Params), allocatable :: params(:) + + params = [ & + ErfR8Params(0._r8, 0._r8), & + ErfR8Params(30._r8, 1._r8), & + ErfR8Params(-30._r8, -1._r8), & + ErfR8Params(1._r8, 0.842700792949714869341, tol=1.e-6_r8), & + ErfR8Params(-1._r8, -0.842700792949714869341, tol=1.e-6_r8) ] + +end function getParameters + +function toString(this) result(string) + class(ErfR8Params), intent(in) :: this + character(:), allocatable :: string + + character(len=80) :: buffer + + write(buffer, '(A,F8.4,A,F8.4,A)') & + "(point = ",this%test_point,", erf = ",this%erf_val,")" + + string = trim(buffer) + +end function toString + +! Check that the erf function gets the expected result. +@Test +subroutine erf_r8_has_correct_value(this) + class(TestErfR8), intent(inout) :: this + @assertEqual(this%erf_val, erf(this%test_point), tolerance=this%tol) +end subroutine erf_r8_has_correct_value + +! Check that two runs of the erf function get identical results. +@Test +subroutine erf_r8_is_reproducible(this) + class(TestErfR8), intent(inout) :: this + @assertEqual(erf(this%test_point), erf(this%test_point)) +end subroutine erf_r8_is_reproducible + +! Check that erfc(x) = 1 - erf(x). +@Test +subroutine erfc_r8_has_correct_value(this) + class(TestErfR8), intent(inout) :: this + @assertEqual(1._r8 - this%erf_val, erfc(this%test_point), tolerance=this%tol) +end subroutine erfc_r8_has_correct_value + +! Check that two runs of the erfc function get identical results. +@Test +subroutine erfc_r8_is_reproducible(this) + class(TestErfR8), intent(inout) :: this + @assertEqual(erfc(this%test_point), erfc(this%test_point)) +end subroutine erfc_r8_is_reproducible + +! Check that erfc_scaled(x) = exp(x**2) * (1 - erf(x)). +@Test +subroutine erfc_scaled_r8_has_correct_value(this) + class(TestErfR8), intent(inout) :: this + real(r8) :: erfc_scaled_expected + + ! Distinguish between where the test point has a modest value, or is too + ! big to use a naive calculation. + if (abs(this%test_point) < erfc_scaled_overflow) then + erfc_scaled_expected = exp(this%test_point**2)*(1._r8 - this%erf_val) + else + ! For larger positive values, we could use an approximation, but this + ! is not trivial. Large negative values should overflow; the only + ! thing we could possibly check in that case would be to ensure that + ! the implementation throws a floating-point error. + + ! For now, just automatically pass the test for large values. + return + end if + + @assertEqual(erfc_scaled_expected, erfc_scaled(this%test_point), tolerance=this%tol) +end subroutine erfc_scaled_r8_has_correct_value + +! Check that two runs of the erfc_scaled function get identical results. +@Test +subroutine erfc_scaled_r8_is_reproducible(this) + class(TestErfR8), intent(inout) :: this + ! Skip this if we overflow. + if (this%test_point < -erfc_scaled_overflow) return + @assertEqual(erfc_scaled(this%test_point), erfc_scaled(this%test_point)) +end subroutine erfc_scaled_r8_is_reproducible + +end module test_erf_r8 diff --git a/src/csm_share/util/test/shr_spfn_test/test_gamma_factorial.pf b/src/csm_share/util/test/shr_spfn_test/test_gamma_factorial.pf new file mode 100644 index 0000000000..1b99f563fb --- /dev/null +++ b/src/csm_share/util/test/shr_spfn_test/test_gamma_factorial.pf @@ -0,0 +1,98 @@ +module test_gamma_factorial + +use funit + +use shr_kind_mod, only: & + r8 => shr_kind_r8, & + i8 => shr_kind_i8 + +use shr_spfn_mod, only: & + gamma => shr_spfn_gamma, & + igamma => shr_spfn_igamma + +implicit none +save + +real(r8), parameter :: relative_error_tolerance = 1.e-12_r8 + +@TestParameter +type, extends(AbstractTestParameter) :: GammaTestInt + integer :: test_int + contains + procedure :: toString +end type GammaTestInt + +@TestCase(testParameters={getParameters()}, constructor=new_TestGammaFac) +type, extends(ParameterizedTestCase) :: TestGammaFac + real(r8) :: input_int + real(r8) :: test_factorial +end type TestGammaFac + +contains + +function new_TestGammaFac(params) result(test) + type(GammaTestInt), intent(in) :: params + type(TestGammaFac) :: test + + test%input_int = real(params%test_int,r8) + + ! A curious fact; because the factorial contains so many powers of 2, 20! + ! is exactly representable in an 8 byte double even though it is bigger + ! than 1/epsilon. + test%test_factorial = real(factorial(params%test_int-1),r8) + +contains + + function factorial(n) + integer, intent(in) :: n + integer(i8) :: factorial + integer(i8) :: i + factorial = product([( i, i = 1, n )]) + end function factorial + +end function new_TestGammaFac + +function getParameters() result(params) + type(GammaTestInt), allocatable :: params(:) + + integer :: i + + params = [( GammaTestInt(i), i = 1, 21 )] + +end function getParameters + +function toString(this) result(string) + class(GammaTestInt), intent(in) :: this + character(:), allocatable :: string + + character(len=80) :: buffer + + write(buffer, *) "(n = ",this%test_int,")" + + string = trim(buffer) + +end function toString + +@Test +subroutine gamma_is_factorial(this) + class(TestGammaFac), intent(inout) :: this + + real(r8) :: tol + + tol = relative_error_tolerance * this%test_factorial + + @assertEqual(this%test_factorial, gamma(this%input_int), tolerance=tol) +end subroutine gamma_is_factorial + +@Test +subroutine igamma_is_factorial(this) + class(TestGammaFac), intent(inout) :: this + + real(r8) :: tol + + tol = relative_error_tolerance * this%test_factorial + + @assertEqual(this%test_factorial, igamma(this%input_int,0._r8), tolerance=tol) +end subroutine igamma_is_factorial + +end module test_gamma_factorial diff --git a/src/csm_share/util/test/shr_spfn_test/test_igamma.pf b/src/csm_share/util/test/shr_spfn_test/test_igamma.pf new file mode 100644 index 0000000000..f663af9132 --- /dev/null +++ b/src/csm_share/util/test/shr_spfn_test/test_igamma.pf @@ -0,0 +1,42 @@ +module test_igamma + +use funit + +use shr_kind_mod, only: & + r8 => shr_kind_r8 + +use shr_const_mod, only: & + pi => shr_const_pi + +use shr_spfn_mod, only: & + igamma => shr_spfn_igamma, & + erfc => shr_spfn_erfc + +implicit none +save + +real(r8), parameter :: relative_error_tolerance = 1.e-12_r8 + +contains + +! igamma(1,x) = exp(-x) +! => igamma(1,1) = exp(-1) +@Test +subroutine igamma_matches_exp_1() + real(r8) :: tol + tol = relative_error_tolerance*exp(-1._r8) + @assertEqual(exp(-1._r8), igamma(1._r8, 1._r8), tolerance=tol) +end subroutine igamma_matches_exp_1 + +! igamma(1/2,x) = sqrt(pi)*erfc(sqrt(x)) +! => igamma(0.5,1) = sqrt(pi)*erfc(1) +@Test +subroutine igamma_matches_erfc_1() + real(r8) :: expected + real(r8) :: tol + expected = sqrt(pi)*erfc(1._r8) + tol = relative_error_tolerance*expected + @assertEqual(expected, igamma(0.5_r8, 1._r8), tolerance=tol) +end subroutine igamma_matches_erfc_1 + +end module test_igamma diff --git a/src/csm_share/util/test/shr_strconvert_test/test_toString.pf b/src/csm_share/util/test/shr_strconvert_test/test_toString.pf new file mode 100644 index 0000000000..ce55b4125c --- /dev/null +++ b/src/csm_share/util/test/shr_strconvert_test/test_toString.pf @@ -0,0 +1,165 @@ +module test_toString + +! Simple tests for printing intrinsic types. +! +! This module is somewhat repetitive, but it seems manageable enough that it's +! not worth invoking complex methods such as genf90, cpp hacks, or parameterized +! pFUnit tests to handle the different types. + +use funit + +use shr_kind_mod, only: & + i4 => shr_kind_i4, & + i8 => shr_kind_i8, & + r4 => shr_kind_r4, & + r8 => shr_kind_r8 + +use shr_infnan_mod, only: & + posinf => shr_infnan_posinf, & + neginf => shr_infnan_neginf, & + qnan => shr_infnan_qnan, & + snan => shr_infnan_snan, & + to_r4 => shr_infnan_to_r4, & + to_r8 => shr_infnan_to_r8 + +use shr_strconvert_mod, only: toString + +implicit none + +contains + +@Test +subroutine toString_prints_i4() + @assertEqual("1", toString(1_i4)) +end subroutine toString_prints_i4 + +@Test +subroutine toString_prints_i4_longest_value() + @assertEqual("-2147483648", toString(-huge(1_i4)-1_i4)) +end subroutine toString_prints_i4_longest_value + +@Test +subroutine toString_prints_i4_with_format() + @assertEqual("00001", toString(1_i4, format_string="(I0.5)")) +end subroutine toString_prints_i4_with_format + +@Test +subroutine toString_prints_i8() + @assertEqual("1", toString(1_i8)) +end subroutine toString_prints_i8 + +@Test +subroutine toString_prints_i8_longest_value() + @assertEqual("-9223372036854775808", toString(-huge(1_i8)-1_i8)) +end subroutine toString_prints_i8_longest_value + +@Test +subroutine toString_prints_i8_with_format() + @assertEqual("00001", toString(1_i8, format_string="(I0.5)")) +end subroutine toString_prints_i8_with_format + +@Test +subroutine toString_prints_positive_r4() + @assertEqual("+1.00000000E+00", toString(1._r4)) +end subroutine toString_prints_positive_r4 + +@Test +subroutine toString_prints_negative_r4() + @assertEqual("-1.00000000E+00", toString(-1._r4)) +end subroutine toString_prints_negative_r4 + +@Test +subroutine toString_prints_positive_infinity_r4() + character(len=:), allocatable :: string + string = toString(to_r4(posinf)) + @assertEqual("+Inf", string(1:4)) +end subroutine toString_prints_positive_infinity_r4 + +@Test +subroutine toString_prints_negative_infinity_r4() + character(len=:), allocatable :: string + string = toString(to_r4(neginf)) + @assertEqual("-Inf", string(1:4)) +end subroutine toString_prints_negative_infinity_r4 + +@Test +subroutine toString_prints_qnan_r4() + character(len=:), allocatable :: string + string = toString(to_r4(qnan)) + @assertLessThan(0, len(string), message="String is empty!") + @assertEqual("NaN", string(1:3)) +end subroutine toString_prints_qnan_r4 + +@Test +subroutine toString_prints_snan_r4() + character(len=:), allocatable :: string + string = toString(to_r4(snan)) + @assertLessThan(0, len(string), message="String is empty!") + @assertEqual("NaN", string(1:3)) +end subroutine toString_prints_snan_r4 + +@Test +subroutine toString_prints_r4_with_format() + ! Compiler-specific printing conventions, like the optional leading "+", or + ! putting a "0" before a leading decimal point, are not standardized if + ! format_string is specified. Therefore, pick a value that's not subject to + ! these compiler-defined behaviors. + @assertEqual("-1.50", toString(-1.5_r4, format_string="(F5.2)")) +end subroutine toString_prints_r4_with_format + +@Test +subroutine toString_prints_positive_r8() + @assertEqual("+1.0000000000000000E+000", toString(1._r8)) +end subroutine toString_prints_positive_r8 + +@Test +subroutine toString_prints_negative_r8() + @assertEqual("-1.0000000000000000E+000", toString(-1._r8)) +end subroutine toString_prints_negative_r8 + +@Test +subroutine toString_prints_positive_infinity_r8() + character(len=:), allocatable :: string + string = toString(to_r8(posinf)) + @assertEqual("+Inf", string(1:4)) +end subroutine toString_prints_positive_infinity_r8 + +@Test +subroutine toString_prints_negative_infinity_r8() + character(len=:), allocatable :: string + string = toString(to_r8(neginf)) + @assertEqual("-Inf", string(1:4)) +end subroutine toString_prints_negative_infinity_r8 + +@Test +subroutine toString_prints_qnan_r8() + character(len=:), allocatable :: string + string = toString(to_r8(qnan)) + @assertLessThan(0, len(string), message="String is empty!") + @assertEqual("NaN", string(1:3)) +end subroutine toString_prints_qnan_r8 + +@Test +subroutine toString_prints_snan_r8() + character(len=:), allocatable :: string + string = toString(to_r8(snan)) + @assertLessThan(0, len(string), message="String is empty!") + @assertEqual("NaN", string(1:3)) +end subroutine toString_prints_snan_r8 + +@Test +subroutine toString_prints_r8_with_format() + ! Compiler-specific printing conventions, like the optional leading "+", or + ! putting a "0" before a leading decimal point, are not standardized if + ! format_string is specified. Therefore, pick a value that's not subject to + ! these compiler-defined behaviors. + @assertEqual("-1.50", toString(-1.5_r8, format_string="(F5.2)")) +end subroutine toString_prints_r8_with_format + +@Test +subroutine toString_prints_logical() + @assertEqual("T", toString(.true.)) + @assertEqual("F", toString(.false.)) +end subroutine toString_prints_logical + +end module test_toString diff --git a/src/csm_share/util/test/shr_string_test/test_shr_string.pf b/src/csm_share/util/test/shr_string_test/test_shr_string.pf new file mode 100644 index 0000000000..886f757793 --- /dev/null +++ b/src/csm_share/util/test/shr_string_test/test_shr_string.pf @@ -0,0 +1,194 @@ +module test_shr_string + + ! Tests of shr_string_mod + + use funit + use shr_string_mod + + implicit none + + integer, parameter :: list_len = 256 + character, parameter :: tab_char = char(9) + +contains + + ! ------------------------------------------------------------------------ + ! Tests of shr_string_leftAlign_and_convert_tabs + ! ------------------------------------------------------------------------ + + @Test + subroutine test_shr_string_leftAlign_noInitialSpaces() + ! With no initial spaces, should have no effect + character(len=6) :: str + + str = 'foo ' + call shr_string_leftAlign_and_convert_tabs(str) + @assertEqual('foo ', str, whitespace=KEEP_ALL) + end subroutine test_shr_string_leftAlign_noInitialSpaces + + @Test + subroutine test_shr_string_leftAlign_initialSpacesAndTabs() + ! Should remove an initial mix of spaces and tabs + character(len=8) :: str + + str = ' ' // tab_char // ' ' // tab_char // ' ' // 'foo' + call shr_string_leftAlign_and_convert_tabs(str) + @assertEqual('foo ', str, whitespace=KEEP_ALL) + end subroutine test_shr_string_leftAlign_initialSpacesAndTabs + + @Test + subroutine test_shr_string_leftAlign_interiorSpaces() + ! Should NOT remove interior spaces + character(len=6) :: str + + str = 'f oo ' + call shr_string_leftAlign_and_convert_tabs(str) + @assertEqual('f oo ', str, whitespace=KEEP_ALL) + end subroutine test_shr_string_leftAlign_interiorSpaces + + @Test + subroutine test_shr_string_leftAlign_interiorTabs() + ! Convert interior tabs to spaces + character(len=6) :: str, expected + + str = 'f' // tab_char // 'oo ' + expected = 'f oo ' + call shr_string_leftAlign_and_convert_tabs(str) + @assertEqual(expected, str, whitespace=KEEP_ALL) + end subroutine test_shr_string_leftAlign_interiorTabs + + ! ------------------------------------------------------------------------ + ! Tests of shr_string_listDiff + ! ------------------------------------------------------------------------ + + @Test + subroutine test_shr_string_listDiff_default() + character(len=list_len) :: actual + + call shr_string_listDiff( & + list1 = 'first:second:third:fourth', & + list2 = 'fourth:second', & + listout = actual) + @assertEqual('first:third', actual) + end subroutine test_shr_string_listDiff_default + + @Test + subroutine test_shr_string_listDiff_oneElementList2() + ! Make sure that it correctly handles the edge case of a single element in list2 + ! (i.e., with no delimiters). + character(len=list_len) :: actual + + call shr_string_listDiff( & + list1 = 'first:second:third:fourth', & + list2 = 'third', & + listout = actual) + @assertEqual('first:second:fourth', actual) + end subroutine test_shr_string_listDiff_oneElementList2 + + @Test + subroutine test_shr_string_listDiff_emptyList2() + character(len=list_len) :: actual + + call shr_string_listDiff( & + list1 = 'first:second:third:fourth', & + list2 = ' ', & + listout = actual) + @assertEqual('first:second:third:fourth', actual) + end subroutine test_shr_string_listDiff_emptyList2 + + @Test + subroutine test_shr_string_listDiff_List2equalsList1() + character(len=list_len) :: actual + + call shr_string_listDiff( & + list1 = 'first:second:third:fourth', & + list2 = 'fourth:second:first:third', & ! same as list1, but different order + listout = actual) + @assertEqual(' ', actual) + end subroutine test_shr_string_listDiff_List2equalsList1 + + @Test + subroutine test_shr_string_listDiff_elementNotInList1() + character(len=list_len) :: actual + + call shr_string_listDiff( & + list1 = 'first:second:third:fourth', & + list2 = 'fifth', & + listout = actual) + @assertEqual('first:second:third:fourth', actual) + end subroutine test_shr_string_listDiff_elementNotInList1 + + ! ------------------------------------------------------------------------ + ! Tests of shr_string_listFromSuffixes + ! ------------------------------------------------------------------------ + + @Test + subroutine test_shr_string_listFromSuffixes_with_1() + ! 1 suffix -> list of length 1 + character(len=list_len) :: actual + + actual = shr_string_listFromSuffixes(suffixes = ['_s1'], strBase = 'foo') + @assertEqual('foo_s1', actual) + end subroutine test_shr_string_listFromSuffixes_with_1 + + @Test + subroutine test_shr_string_listFromSuffixes_with_3() + ! 3 suffixes -> list of length 3 + character(len=list_len) :: actual + + actual = shr_string_listFromSuffixes(suffixes = ['_s1', '_s2', '_s3'], strBase = 'foo') + @assertEqual('foo_s1:foo_s2:foo_s3', actual) + end subroutine test_shr_string_listFromSuffixes_with_3 + + ! ------------------------------------------------------------------------ + ! Tests of shr_string_listCreateField + ! ------------------------------------------------------------------------ + + @Test + subroutine test_shr_string_listCreateField_basic() + character(len=list_len) :: actual, expected + + actual = shr_string_listCreateField(numFields = 5, strBase = 'LAI') + expected = 'LAI_1:LAI_2:LAI_3:LAI_4:LAI_5' + @assertEqual(expected, actual) + end subroutine test_shr_string_listCreateField_basic + + ! ------------------------------------------------------------------------ + ! Tests of shr_string_listAddSuffix + ! ------------------------------------------------------------------------ + + @Test + subroutine test_shr_string_listAddSuffix_with_empty_list() + character(len=list_len) :: actual + + call shr_string_listAddSuffix(list=' ', suffix='00', new_list=actual) + @assertEqual(' ', actual) + end subroutine test_shr_string_listAddSuffix_with_empty_list + + @Test + subroutine test_shr_string_listAddSuffix_with_one_element() + character(len=list_len) :: actual + + call shr_string_listAddSuffix(list='first', suffix='00', new_list=actual) + @assertEqual('first00', actual) + end subroutine test_shr_string_listAddSuffix_with_one_element + + @Test + subroutine test_shr_string_listAddSuffix_with_multiple_elements() + character(len=list_len) :: actual, expected + + call shr_string_listAddSuffix(list='first:second:third', suffix='00', new_list=actual) + expected = 'first00:second00:third00' + @assertEqual(expected, actual) + end subroutine test_shr_string_listAddSuffix_with_multiple_elements + + @Test + subroutine test_shr_string_listAddSuffix_with_empty_suffix() + character(len=list_len) :: actual, expected + + call shr_string_listAddSuffix(list='first:second:third', suffix=' ', new_list=actual) + expected = 'first:second:third' + @assertEqual(expected, actual) + end subroutine test_shr_string_listAddSuffix_with_empty_suffix + +end module test_shr_string diff --git a/src/csm_share/util/test/shr_vmath_test/test_vmath.F90 b/src/csm_share/util/test/shr_vmath_test/test_vmath.F90 new file mode 100644 index 0000000000..6bea7453a4 --- /dev/null +++ b/src/csm_share/util/test/shr_vmath_test/test_vmath.F90 @@ -0,0 +1,110 @@ +program test_vmath + +! +! This is a test for the shr_vmath_mod module. +! + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_kind_mod, only: r4 => shr_kind_r4 +use shr_kind_mod, only: i8 => shr_kind_i8 +use shr_kind_mod, only: i4 => shr_kind_i4 +use shr_const_mod, only: pi => shr_const_pi +use shr_vmath_mod + +implicit none +integer, parameter :: vlen = 128 +real(r8) :: ivec(vlen), rvec(vlen), ovec(vlen), nvec(vlen) +real(r8), parameter :: bigval = 1.0E300_r8 +real(r8), parameter :: smallval = 1.0E-300_r8 +real(r8), parameter :: tolerance = 1.0E-15_r8 +integer :: i +call random_number(ivec) ! numbers between 0 and 1 + +ivec = ivec * bigval ! numbers between 0 and 1e308 + +call shr_vmath_sqrt(ivec, rvec, vlen) + +ovec = dsqrt(ivec) +do i=1,vlen + if(abs(rvec(i)-ovec(i)) > tolerance) then + print *,__LINE__,i, ivec(i),rvec(i),ovec(i) + endif +enddo + +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_sqrt test failed") + +call shr_vmath_rsqrt(ivec, rvec, vlen) + +ovec = 1.0_r8/ovec + +do i=1,vlen + if(abs((rvec(i)-ovec(i))/ovec(i)) > tolerance) then + print *,__LINE__,i, ivec(i),rvec(i),ovec(i) + endif +enddo + +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_rsqrt test failed") + +call random_number(nvec) +nvec = (nvec - 0.5_r8)*bigval + +call shr_vmath_div(ivec, nvec, rvec, vlen) + +ovec = ivec/nvec + +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_div test failed") + +call random_number(ivec) +ivec = ivec*1400_r8 - 700_r8 + +call shr_vmath_exp(ivec, rvec, vlen) + +ovec = exp(ivec) +!print *,minval(abs(rvec)),maxval(rvec) + +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_exp test failed") + +ivec = ovec +call shr_vmath_log(ivec, rvec, vlen) +ovec = log(ivec) + +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_log test failed") + +call random_number(ivec) +ivec = (ivec-0.5_r8)*2.0_r8*pi +call shr_vmath_sin(ivec, rvec, vlen) +ovec = sin(ivec) +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_sin test failed") + +call shr_vmath_cos(ivec, rvec, vlen) +ovec = cos(ivec) +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_cos test failed") + +contains + + subroutine assert(val, msg) + logical, intent(in) :: val + character(len=*), intent(in) :: msg + + if (.not. val) then + print *, msg + stop 1 + end if + + end subroutine assert + +end program test_vmath diff --git a/src/csm_share/util/test/shr_wv_sat_test/test_wv_sat.pf b/src/csm_share/util/test/shr_wv_sat_test/test_wv_sat.pf new file mode 100644 index 0000000000..4e37f0628b --- /dev/null +++ b/src/csm_share/util/test/shr_wv_sat_test/test_wv_sat.pf @@ -0,0 +1,256 @@ +module test_wv_sat + +use funit + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_const_mod, only: & + tmelt => shr_const_tkfrz, & + h2otrip => shr_const_tktrip, & + mwwv => shr_const_mwwv, & + mwdair => shr_const_mwdair +use shr_wv_sat_mod + +implicit none +public + +real(r8), parameter :: t_transition = 20._r8 +real(r8), parameter :: epsilo = mwwv/mwdair + +contains + +@Before +subroutine setUp() + + character(len=128) :: errstring + + call shr_wv_sat_init(tmelt, h2otrip, t_transition, epsilo, errstring) + + if (errstring /= "") then + call throw("Error from shr_wv_sat_init: "//trim(errstring)) + end if + +end subroutine setUp + +@After +subroutine tearDown() + call shr_wv_sat_final() +end subroutine tearDown + +@Test +subroutine invalid_name_produces_invalid_index() + + integer :: idx + + idx = shr_wv_sat_get_scheme_idx("NotARealSaturationSchemeName") + @assertTrue(.not. shr_wv_sat_valid_idx(idx)) + +end subroutine invalid_name_produces_invalid_index + +@Test +subroutine reject_out_of_bounds_transition + + character(len=128) :: errstring + + ! Negative transition ranges are meaningless. + call shr_wv_sat_init(tmelt, h2otrip, -1._r8, epsilo, errstring) + @assertTrue(errstring /= "") + + ! A transition range of 0 is OK. + call shr_wv_sat_init(tmelt, h2otrip, 0._r8, epsilo, errstring) + @assertTrue(errstring == "") + +end subroutine reject_out_of_bounds_transition + +@Test +subroutine qsat_not_greater_than_one() + + ! Even if the SVP is greater the current pressure, the saturation specific + ! humidity returned should be capped at 1. + @assertEqual(1.0_r8, shr_wv_sat_svp_to_qsat(1.0_r8, 0.5_r8)) + @assertEqual(1.0_r8, shr_wv_sat_svp_to_qsat(2, [1.0_r8, 2.0_r8], [0.5_r8, 0.5_r8])) + +end subroutine qsat_not_greater_than_one + +@Test +subroutine qmmr_not_greater_than_epsilon() + + integer, parameter :: n = 3 + real(r8), parameter :: es(n) = [0.51_r8, 1.0_r8, 1.5_r8] + real(r8), parameter :: p(n) = [1.0_r8, 1.0_r8, 1.0_r8] + + integer :: i + + ! As SVP becomes close to the actual pressure, the mass mixing ratio goes to + ! infinity, so check that we actually cap it at epsilon once the SVP is more + ! than half the total pressure. + do i = 1, 3 + @assertEqual(epsilo, shr_wv_sat_svp_to_qmmr(es(i), p(i))) + end do + @assertEqual(epsilo, shr_wv_sat_svp_to_qmmr(n, es, p)) + +end subroutine qmmr_not_greater_than_epsilon + +@Test +subroutine esat_not_greater_than_p() + + real(r8) :: es, qs + real(r8) :: es_vec(1), qs_vec(1) + + ! For the combined routine, we don't allow the SVP to exceed the current + ! pressure. Tested here by simply providing an extremely low pressure. + + ! This is a guard against schemes that "blindly" attempt to reach saturation + ! by evaporating cloud water, no matter what the conditions. At very low + ! pressures this is impossible, so we return a limited value to prevent + ! numerical issues. + + call shr_wv_sat_qsat_liquid(280._r8, 1.e-30_r8, es, qs) + @assertEqual(1.e-30_r8, es) + + call shr_wv_sat_qsat_liquid(1, [280._r8], [1.e-30_r8], es_vec, qs_vec) + @assertEqual([1.e-30_r8], es_vec) + + call shr_wv_sat_qsat_ice(260._r8, 1.e-30_r8, es, qs) + @assertEqual(1.e-30_r8, es) + + call shr_wv_sat_qsat_ice(1, [260._r8], [1.e-30_r8], es_vec, qs_vec) + @assertEqual([1.e-30_r8], es_vec) + + call shr_wv_sat_qsat_mixed(270._r8, 1.e-30_r8, es, qs) + @assertEqual(1.e-30_r8, es) + + call shr_wv_sat_qsat_mixed(1, [270._r8], [1.e-30_r8], es_vec, qs_vec) + @assertEqual([1.e-30_r8], es_vec) + +end subroutine esat_not_greater_than_p + +@Test +subroutine liquid_vapor_table_is_used() + type(ShrWVSatTableSpec) :: liquid_table_spec + + real(r8) :: non_table_value + real(r8) :: table_value + + non_table_value = shr_wv_sat_svp_liquid(tmelt+7.5_r8) + + liquid_table_spec = ShrWVSatTableSpec(151, tmelt-50._r8, 1._r8) + call shr_wv_sat_make_tables(liquid_spec_in=liquid_table_spec) + + table_value = shr_wv_sat_svp_liquid(tmelt+7.5_r8) + + ! We can't really see directly whether the table is used, but we can pick a + ! value that requires interpolation and look for the difference. + @assertFalse(non_table_value == table_value) + +end subroutine liquid_vapor_table_is_used + +@Test +subroutine liquid_vapor_table_not_extrapolated() + type(ShrWVSatTableSpec) :: liquid_table_spec + + real(r8) :: non_table_low_value, non_table_high_value + real(r8) :: table_low_value, table_high_value + + non_table_low_value = shr_wv_sat_svp_liquid(tmelt-50.5_r8) + non_table_high_value = shr_wv_sat_svp_liquid(tmelt+150.5_r8) + + liquid_table_spec = ShrWVSatTableSpec(151, tmelt-50._r8, 1._r8) + call shr_wv_sat_make_tables(liquid_spec_in=liquid_table_spec) + + table_low_value = shr_wv_sat_svp_liquid(tmelt-50.5_r8) + table_high_value = shr_wv_sat_svp_liquid(tmelt+150.5_r8) + + ! Beyond the table boundaries, the lookup table should not be used, and so we + ! should get the same answer as before specifying any tables. + @assertEqual(non_table_low_value, table_low_value) + @assertEqual(non_table_high_value, table_high_value) + +end subroutine liquid_vapor_table_not_extrapolated + +@Test +subroutine ice_vapor_table_is_used() + type(ShrWVSatTableSpec) :: ice_table_spec + + real(r8) :: non_table_value + real(r8) :: table_value + + non_table_value = shr_wv_sat_svp_ice(tmelt-7.5_r8) + + ice_table_spec = ShrWVSatTableSpec(106, tmelt-100._r8, 1._r8) + call shr_wv_sat_make_tables(ice_spec_in=ice_table_spec) + + table_value = shr_wv_sat_svp_ice(tmelt-7.5_r8) + + ! We can't really see directly whether the table is used, but we can pick a + ! value that requires interpolation and look for the difference. + @assertFalse(non_table_value == table_value) + +end subroutine ice_vapor_table_is_used + +@Test +subroutine ice_vapor_table_not_extrapolated() + type(ShrWVSatTableSpec) :: ice_table_spec + + real(r8) :: non_table_low_value, non_table_high_value + real(r8) :: table_low_value, table_high_value + + non_table_low_value = shr_wv_sat_svp_ice(tmelt-100.5_r8) + non_table_high_value = shr_wv_sat_svp_ice(tmelt+5.5_r8) + + ice_table_spec = ShrWVSatTableSpec(106, tmelt-100._r8, 1._r8) + call shr_wv_sat_make_tables(ice_spec_in=ice_table_spec) + + table_low_value = shr_wv_sat_svp_ice(tmelt-100.5_r8) + table_high_value = shr_wv_sat_svp_ice(tmelt+5.5_r8) + + ! Beyond the table boundaries, the lookup table should not be used, and so we + ! should get the same answer as before specifying any tables. + @assertEqual(non_table_low_value, table_low_value) + @assertEqual(non_table_high_value, table_high_value) + +end subroutine ice_vapor_table_not_extrapolated + +@Test +subroutine mixed_vapor_table_is_used() + type(ShrWVSatTableSpec) :: mixed_table_spec + + real(r8) :: non_table_value + real(r8) :: table_value + + non_table_value = shr_wv_sat_svp_mixed(tmelt-7.5_r8) + + mixed_table_spec = ShrWVSatTableSpec(201, tmelt-100._r8, 1._r8) + call shr_wv_sat_make_tables(mixed_spec_in=mixed_table_spec) + + table_value = shr_wv_sat_svp_mixed(tmelt-7.5_r8) + + ! We can't really see directly whether the table is used, but we can pick a + ! value that requires interpolation and look for the difference. + @assertFalse(non_table_value == table_value) + +end subroutine mixed_vapor_table_is_used + +@Test +subroutine mixed_vapor_table_not_extrapolated() + type(ShrWVSatTableSpec) :: mixed_table_spec + + real(r8) :: non_table_low_value, non_table_high_value + real(r8) :: table_low_value, table_high_value + + non_table_low_value = shr_wv_sat_svp_mixed(tmelt-100.5_r8) + non_table_high_value = shr_wv_sat_svp_mixed(tmelt+100.5_r8) + + mixed_table_spec = ShrWVSatTableSpec(201, tmelt-100._r8, 1._r8) + call shr_wv_sat_make_tables(mixed_spec_in=mixed_table_spec) + + table_low_value = shr_wv_sat_svp_mixed(tmelt-100.5_r8) + table_high_value = shr_wv_sat_svp_mixed(tmelt+100.5_r8) + + ! Beyond the table boundaries, the lookup table should not be used, and so we + ! should get the same answer as before specifying any tables. + @assertEqual(non_table_low_value, table_low_value) + @assertEqual(non_table_high_value, table_high_value) + +end subroutine mixed_vapor_table_not_extrapolated + +end module test_wv_sat diff --git a/src/csm_share/util/test/shr_wv_sat_test/test_wv_sat_each_method.pf b/src/csm_share/util/test/shr_wv_sat_test/test_wv_sat_each_method.pf new file mode 100644 index 0000000000..5eafcdd89e --- /dev/null +++ b/src/csm_share/util/test/shr_wv_sat_test/test_wv_sat_each_method.pf @@ -0,0 +1,270 @@ +! This module has a parameterized test list for application to each of the +! individual methods provided by shr_wv_sat_mod. +module test_wv_sat_each_method + +use funit + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_const_mod, only: & + tmelt => shr_const_tkfrz, & + h2otrip => shr_const_tktrip, & + mwwv => shr_const_mwwv, & + mwdair => shr_const_mwdair +use shr_wv_sat_mod + +implicit none +public + +real(r8), parameter :: t_transition = 20._r8 + +@TestParameter +type, extends(AbstractTestParameter) :: WVSchemeParameters + character(len=32) :: scheme_name + real(r8) :: relative_tol + logical :: make_table + logical :: use_vector + contains + procedure :: toString +end type WVSchemeParameters + +@TestCase(testParameters={getParameters()}, constructor=new_WVSchemeCase) +type, extends(ParameterizedTestCase) :: WVSchemeCase + character(len=32) :: scheme_name + real(r8) :: relative_tol + logical :: make_table + logical :: use_vector + contains + procedure :: setUp + procedure :: tearDown +end type WVSchemeCase + +contains + +! Simple routines to convert parameters to a test case or a string, +! respectively. + +function new_WVSchemeCase(params) result(test) + type(WVSchemeParameters), intent(in) :: params + type(WVSchemeCase) :: test + + test%scheme_name = params%scheme_name + test%relative_tol = params%relative_tol + test%make_table = params%make_table + test%use_vector = params%use_vector + +end function new_WVSchemeCase + +function toString(this) result(string) + class(WVSchemeParameters), intent(in) :: this + character(:), allocatable :: string + + character(len=80) :: buffer + + write(buffer,*) "(scheme=",this%scheme_name,",table=",this%make_table, & + ",vec=",this%use_vector,")" + + string = trim(buffer) + +end function toString + +! setUp/tearDown to init the module and to actually set the current scheme. +subroutine setUp(this) + + class(WVSchemeCase), intent(inout) :: this + + real(r8), parameter :: epsilo = mwwv/mwdair + + character(len=128) :: errstring + + type(ShrWVSatTableSpec) :: liquid_table_spec, ice_table_spec, mixed_table_spec + + call shr_wv_sat_init(tmelt, h2otrip, t_transition, epsilo, errstring) + + if (errstring /= "") then + call throw("Error from shr_wv_sat_init: "//trim(errstring)) + end if + + @assertTrue(shr_wv_sat_set_default(this%scheme_name)) + + if (this%make_table) then + liquid_table_spec = ShrWVSatTableSpec(151, tmelt-50._r8, 1._r8) + ice_table_spec = ShrWVSatTableSpec(106, tmelt-100._r8, 1._r8) + mixed_table_spec = ShrWVSatTableSpec(201, tmelt-100._r8, 1._r8) + call shr_wv_sat_make_tables(& + liquid_spec_in=liquid_table_spec, & + ice_spec_in=ice_table_spec, & + mixed_spec_in=mixed_table_spec) + end if + +end subroutine setUp + +subroutine tearDown(this) + + class(WVSchemeCase), intent(inout) :: this + + call shr_wv_sat_final() + +end subroutine tearDown + +! List of testable schemes. + +function getParameters() result(params) + type(WVSchemeParameters), allocatable :: params(:) + + params = [ & + WVSchemeParameters("GoffGratch", 0.002_r8, .false., .false.), & + WVSchemeParameters("MurphyKoop", 0.001_r8, .false., .false.), & + WVSchemeParameters("Flatau", 0.003_r8, .false., .false.), & + WVSchemeParameters("Bolton", 0.001_r8, .false., .false.), & + WVSchemeParameters("GoffGratch", 0.002_r8, .true., .false.), & + WVSchemeParameters("GoffGratch", 0.002_r8, .false., .true.), & + WVSchemeParameters("GoffGratch", 0.002_r8, .true., .true.) ] + +end function getParameters + +! Tests for water and ice functions for each scheme. + +@Test +subroutine scheme_has_correct_ice_trip_point(this) + class(WVSchemeCase), intent(inout) :: this + + if (this%use_vector) then + call assertRelativelyEqual([611.7_r8], shr_wv_sat_svp_ice(1, [h2otrip]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(611.7_r8, shr_wv_sat_svp_ice(h2otrip), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_ice_trip_point + +@Test +subroutine scheme_has_correct_liquid_trip_point(this) + class(WVSchemeCase), intent(inout) :: this + + if (this%use_vector) then + call assertRelativelyEqual([611.7_r8], shr_wv_sat_svp_liquid(1, [h2otrip]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(611.7_r8, shr_wv_sat_svp_liquid(h2otrip), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_liquid_trip_point + +@Test +subroutine scheme_has_correct_liquid_value(this) + class(WVSchemeCase), intent(inout) :: this + + ! Check a warm value (25 deg C). + if (this%use_vector) then + call assertRelativelyEqual([3169._r8], shr_wv_sat_svp_liquid(1, [tmelt+25._r8]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(3169._r8, shr_wv_sat_svp_liquid(tmelt+25._r8), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_liquid_value + +@Test +subroutine scheme_has_correct_ice_value(this) + class(WVSchemeCase), intent(inout) :: this + + ! Check a cold value (-50 deg C). + if (this%use_vector) then + call assertRelativelyEqual([3.935], shr_wv_sat_svp_ice(1, [tmelt-50._r8]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(3.935, shr_wv_sat_svp_ice(tmelt-50._r8), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_ice_value + +! Tests for the combined water-ice function with transition range. +! Technically, these don't have to be done for each scheme, but it doesn't hurt +! to run them many times, since the tests are very quick. + +@Test +subroutine scheme_has_correct_mixed_trip_point(this) + class(WVSchemeCase), intent(inout) :: this + + if (this%use_vector) then + call assertRelativelyEqual([611.7_r8], shr_wv_sat_svp_mixed(1, [h2otrip]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(611.7_r8, shr_wv_sat_svp_mixed(h2otrip), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_mixed_trip_point + +@Test +subroutine scheme_has_correct_mixed_as_ice(this) + class(WVSchemeCase), intent(inout) :: this + + real(r8) :: t_all_ice = tmelt - t_transition - 1._r8 + + real(r8) :: ice_svp + + ice_svp = shr_wv_sat_svp_ice(t_all_ice) + + ! Below the transition range, trans and ice should be equal. + if (this%use_vector) then + call assertRelativelyEqual([ice_svp], shr_wv_sat_svp_mixed(1, [t_all_ice]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(ice_svp, shr_wv_sat_svp_mixed(t_all_ice), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_mixed_as_ice + +@Test +subroutine scheme_has_correct_mixed_as_liquid(this) + class(WVSchemeCase), intent(inout) :: this + + real(r8) :: t_all_liquid = tmelt + 1._r8 + + real(r8) :: liquid_svp + + liquid_svp = shr_wv_sat_svp_liquid(t_all_liquid) + + ! Above the transition range, trans and water should be equal. + if (this%use_vector) then + call assertRelativelyEqual([liquid_svp], shr_wv_sat_svp_mixed(1, [t_all_liquid]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(liquid_svp, shr_wv_sat_svp_mixed(t_all_liquid), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_mixed_as_liquid + +@Test +subroutine scheme_has_correct_mixed_in_range(this) + class(WVSchemeCase), intent(inout) :: this + + ! Temperature at which we are halfway through the transition range. + real(r8), parameter :: t_half = tmelt - 0.5*t_transition + + real(r8) :: ice_svp, liquid_svp + + ice_svp = shr_wv_sat_svp_ice(t_half) + liquid_svp = shr_wv_sat_svp_liquid(t_half) + + ! Check that transition SVP is the average of the ice and water SVPs. + if (this%use_vector) then + call assertRelativelyEqual([0.5_r8 * (ice_svp+liquid_svp)], & + shr_wv_sat_svp_mixed(1, [t_half]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(0.5_r8 * (ice_svp+liquid_svp), & + shr_wv_sat_svp_mixed(t_half), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_mixed_in_range + +end module test_wv_sat_each_method