├── src ├── stubs │ └── smartredis │ │ ├── README.md │ │ ├── put_tensor_methods_common.inc │ │ └── unpack_tensor_methods_common.inc ├── CMakeLists.txt ├── shr_kind_mod.F90 ├── shr_precip_mod.F90 ├── shr_reprosumx86.c ├── shr_nl_mod.F90 ├── shr_mem_mod.F90 ├── shr_abort_mod.F90 ├── shr_frz_mod.F90.in ├── shr_log_mod.F90 ├── shr_strconvert_mod.F90 ├── water_isotopes │ └── water_types.F90 ├── shr_const_mod.F90 ├── shr_vmath_mod.F90 └── shr_pio_mod.F90 ├── test └── unit │ ├── mock │ ├── CMakeLists.txt │ ├── README │ └── shr_sys_mod.nompi_abortthrows.F90 │ ├── shr_abort_test │ ├── README │ ├── CMakeLists.txt │ └── test_shr_abort.pf │ ├── shr_strconvert_test │ ├── CMakeLists.txt │ └── test_toString.pf │ ├── shr_precip_test │ ├── CMakeLists.txt │ └── test_shr_precip.pf │ ├── shr_infnan_test │ ├── CMakeLists.txt │ └── test_infnan.F90 │ ├── shr_wv_sat_test │ ├── CMakeLists.txt │ ├── test_wv_sat.pf │ └── test_wv_sat_each_method.pf │ ├── dynamic_vector │ ├── dynamic_vector_integer.F90 │ ├── dynamic_vector_character16.F90 │ ├── dynamic_vector_int_ptr.F90 │ ├── dynamic_vector_r8.F90 │ ├── integer_vector_tests.pf.in │ ├── r8_vector_tests.pf.in │ ├── ptr_wrapper.F90 │ ├── character16_vector_tests.pf.in │ ├── int_ptr_vector_tests.pf.in │ └── CMakeLists.txt │ ├── CMakeLists.txt │ ├── shr_log_test │ ├── CMakeLists.txt │ └── test_error_printers.pf │ ├── shr_vmath_test │ ├── CMakeLists.txt │ └── test_vmath.F90 │ ├── shr_assert_test │ ├── CMakeLists.txt │ ├── test_assert.pf │ ├── test_ndebug.pf │ ├── test_macro.pf │ └── test_assert_array.pf │ ├── shr_spfn_test │ ├── CMakeLists.txt │ ├── test_igamma.pf │ ├── test_gamma_factorial.pf │ ├── test_erf_r4.pf │ └── test_erf_r8.pf │ ├── shr_string_test │ └── CMakeLists.txt │ └── shr_cal_test │ └── CMakeLists.txt ├── unit_test_stubs ├── util │ ├── CMakeLists.txt │ ├── README │ └── shr_abort_mod.abortthrows.F90 ├── pio │ ├── README │ └── CMakeLists.txt └── README ├── .gitignore ├── .github ├── workflows │ ├── bumpversion.yml │ └── extbuild.yml └── actions │ └── buildshare │ └── action.yaml ├── RandNum ├── src │ ├── dsfmt_f03 │ │ └── dSFMT_utils.c │ └── kissvec │ │ ├── kissvec.c │ │ └── kissvec_mod.F90 ├── include │ ├── dSFMT-params19937.h │ ├── dSFMT-params.h │ └── dSFMT-common.h └── test │ └── bench │ ├── Makefile │ └── test_shr_RandNum.F90 ├── include └── shr_assert.h ├── cmake ├── FindMPISERIAL.cmake ├── FindPIO.cmake ├── LibCheck.cmake └── FindESMF.cmake ├── LICENSE.TXT ├── README.md └── CMakeLists.txt /src/stubs/smartredis/README.md: -------------------------------------------------------------------------------- 1 | This is a stub interface to the SmartRedis tools and should only be used when 2 | CESM is built without SmartRedis. -------------------------------------------------------------------------------- /test/unit/mock/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | list(APPEND share_sources 2 | shr_sys_mod.nompi_abortthrows.F90) 3 | 4 | sourcelist_to_parent(share_sources) 5 | -------------------------------------------------------------------------------- /unit_test_stubs/util/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | list(APPEND share_sources 2 | shr_abort_mod.abortthrows.F90) 3 | 4 | sourcelist_to_parent(share_sources) 5 | -------------------------------------------------------------------------------- /unit_test_stubs/pio/README: -------------------------------------------------------------------------------- 1 | This directory contains a stub implementation of (a subset of) PIO. This can be 2 | built in place of the true PIO library in unit tests. 3 | -------------------------------------------------------------------------------- /test/unit/shr_abort_test/README: -------------------------------------------------------------------------------- 1 | This directory tests the version of shr_abort_mod that is used in unit tests. It 2 | does NOT test the production version of shr_abort_mod. 3 | -------------------------------------------------------------------------------- /unit_test_stubs/README: -------------------------------------------------------------------------------- 1 | This directory contains stubs and other unit test-specific implementations that 2 | may be useful for the unit test builds for a number of components. 3 | -------------------------------------------------------------------------------- /test/unit/mock/README: -------------------------------------------------------------------------------- 1 | This directory contains mock/stub modules that are just built as part of select 2 | unit tests of the share code. This directory should *NOT* generally be added by 3 | unit tests of other components. 4 | 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Ignore python bytecode files 2 | *.pyc 3 | buildnmlc 4 | buildlib.*c 5 | buildlib.csm_sharec 6 | 7 | # Ignore emacs backup files 8 | *~ 9 | 10 | # Typical directory used for unit test build 11 | /unit_tests.temp/ 12 | 13 | -------------------------------------------------------------------------------- /unit_test_stubs/util/README: -------------------------------------------------------------------------------- 1 | This directory contains some fake modules that should generally be used in place 2 | of their real counterparts by ALL unit tests. So this directory generally should 3 | be added by unit tests of other components. 4 | -------------------------------------------------------------------------------- /unit_test_stubs/pio/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set(genf90_files pio.F90.in) 2 | 3 | process_genf90_source_list("${genf90_files}" ${CMAKE_CURRENT_BINARY_DIR} 4 | pio_genf90_sources) 5 | 6 | sourcelist_to_parent(pio_genf90_sources) 7 | 8 | list(APPEND pio_sources "${pio_genf90_sources}") 9 | 10 | sourcelist_to_parent(pio_sources) -------------------------------------------------------------------------------- /src/stubs/smartredis/put_tensor_methods_common.inc: -------------------------------------------------------------------------------- 1 | class(client_type), intent(in) :: this !< Fortran SLIC client 2 | character(len=*), intent(in) :: key !< The unique key used to store in the database 3 | integer, dimension(:), intent(in) :: dims !< The length of each dimension 4 | -------------------------------------------------------------------------------- /src/stubs/smartredis/unpack_tensor_methods_common.inc: -------------------------------------------------------------------------------- 1 | class(client_type), intent(in) :: this !< Pointer to the initialized client 2 | character(len=*), intent(in) :: key !< The key to use to place the tensor 3 | integer, dimension(:), intent(in) :: dims !< Length along each dimension of the tensor 4 | -------------------------------------------------------------------------------- /test/unit/shr_strconvert_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set(pf_sources 2 | test_toString.pf) 3 | 4 | set(sources_needed shr_kind_mod.F90 shr_infnan_mod.F90 5 | shr_strconvert_mod.F90) 6 | 7 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 8 | 9 | add_pfunit_ctest(shr_strconvert 10 | TEST_SOURCES "${pf_sources}" 11 | OTHER_SOURCES "${test_sources}") 12 | 13 | declare_generated_dependencies(shr_strconvert "${share_genf90_sources}") 14 | -------------------------------------------------------------------------------- /test/unit/shr_abort_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Local pFUnit files. 2 | set(pf_sources 3 | test_shr_abort.pf) 4 | 5 | # Sources to test. 6 | set(sources_needed 7 | shr_kind_mod.F90 8 | shr_abort_mod.abortthrows.F90) 9 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 10 | 11 | # Do source preprocessing and add the executable. 12 | add_pfunit_ctest(shr_abort_mod 13 | TEST_SOURCES "${pf_sources}" 14 | OTHER_SOURCES "${test_sources}") 15 | -------------------------------------------------------------------------------- /test/unit/shr_precip_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Local pFUnit files. 2 | set(pf_sources 3 | test_shr_precip.pf) 4 | 5 | # Sources to test. 6 | set(sources_needed 7 | shr_kind_mod.F90 shr_const_mod.F90 shr_precip_mod.F90) 8 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 9 | 10 | # Do source preprocessing and add the executable. 11 | add_pfunit_ctest(shr_precip_mod 12 | TEST_SOURCES "${pf_sources}" 13 | OTHER_SOURCES "${test_sources}") 14 | -------------------------------------------------------------------------------- /test/unit/shr_infnan_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set(test_sources test_infnan.F90) 2 | 3 | set(sources_needed shr_kind_mod.F90 shr_infnan_mod.F90) 4 | 5 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 6 | 7 | add_executable(infnan_test_exe ${test_sources}) 8 | 9 | declare_generated_dependencies(infnan_test_exe "${share_genf90_sources}") 10 | 11 | # Add the actual test. 12 | add_test(infnan infnan_test_exe) 13 | 14 | define_Fortran_stop_failure(infnan) 15 | -------------------------------------------------------------------------------- /test/unit/shr_wv_sat_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Local pFUnit files. 2 | set(pf_sources 3 | test_wv_sat.pf test_wv_sat_each_method.pf) 4 | 5 | # Sources to test. 6 | set(sources_needed 7 | shr_kind_mod.F90 shr_const_mod.F90 shr_wv_sat_mod.F90) 8 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 9 | 10 | # Do source preprocessing and add the executable. 11 | add_pfunit_ctest(shr_wv_sat_mod 12 | TEST_SOURCES "${pf_sources}" 13 | OTHER_SOURCES "${test_sources}") 14 | -------------------------------------------------------------------------------- /test/unit/dynamic_vector/dynamic_vector_integer.F90: -------------------------------------------------------------------------------- 1 | module dynamic_vector_integer 2 | 3 | use funit, only: throw 4 | 5 | use shr_log_mod, only: OOBMsg => shr_log_OOBMsg 6 | 7 | implicit none 8 | private 9 | 10 | #define VECTOR_NAME integer_vector 11 | #define TYPE_NAME integer 12 | #define THROW(string) call throw(string) 13 | 14 | public :: VECTOR_NAME 15 | 16 | #include "dynamic_vector_typedef.inc" 17 | 18 | contains 19 | 20 | #include "dynamic_vector_procdef.inc" 21 | 22 | end module dynamic_vector_integer 23 | -------------------------------------------------------------------------------- /test/unit/dynamic_vector/dynamic_vector_character16.F90: -------------------------------------------------------------------------------- 1 | module dynamic_vector_character16 2 | 3 | use funit, only: throw 4 | 5 | use shr_log_mod, only: OOBMsg => shr_log_OOBMsg 6 | 7 | implicit none 8 | private 9 | 10 | #define VECTOR_NAME character16_vector 11 | #define TYPE_NAME character(len=16) 12 | #define THROW(string) call throw(string) 13 | 14 | public :: VECTOR_NAME 15 | 16 | #include "dynamic_vector_typedef.inc" 17 | 18 | contains 19 | 20 | #include "dynamic_vector_procdef.inc" 21 | 22 | end module dynamic_vector_character16 23 | -------------------------------------------------------------------------------- /.github/workflows/bumpversion.yml: -------------------------------------------------------------------------------- 1 | name: Bump version 2 | on: 3 | push: 4 | branches: 5 | - main 6 | jobs: 7 | build: 8 | runs-on: ubuntu-latest 9 | steps: 10 | - uses: actions/checkout@v5 11 | - name: Bump version and push tag 12 | id: tag_version 13 | uses: mathieudutour/github-tag-action@v6.2 14 | with: 15 | github_token: ${{ secrets.GITHUB_TOKEN }} 16 | create_annotated_tag: true 17 | default_bump: patch 18 | dry_run: false 19 | tag_prefix: share 20 | -------------------------------------------------------------------------------- /test/unit/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | add_subdirectory(mock) 2 | 3 | add_subdirectory(shr_abort_test) 4 | 5 | add_subdirectory(shr_assert_test) 6 | 7 | add_subdirectory(shr_spfn_test) 8 | 9 | add_subdirectory(shr_infnan_test) 10 | 11 | add_subdirectory(shr_string_test) 12 | 13 | add_subdirectory(shr_strconvert_test) 14 | 15 | add_subdirectory(shr_log_test) 16 | 17 | add_subdirectory(dynamic_vector) 18 | 19 | add_subdirectory(shr_vmath_test) 20 | 21 | add_subdirectory(shr_wv_sat_test) 22 | 23 | add_subdirectory(shr_precip_test) 24 | 25 | add_subdirectory(shr_cal_test) -------------------------------------------------------------------------------- /test/unit/dynamic_vector/dynamic_vector_int_ptr.F90: -------------------------------------------------------------------------------- 1 | module dynamic_vector_int_ptr 2 | 3 | use ptr_wrapper, only: int_ptr 4 | 5 | use funit, only: throw 6 | 7 | use shr_log_mod, only: OOBMsg => shr_log_OOBMsg 8 | 9 | implicit none 10 | private 11 | 12 | #define VECTOR_NAME int_ptr_vector 13 | #define TYPE_NAME type(int_ptr) 14 | #define THROW(string) call throw(string) 15 | 16 | public :: VECTOR_NAME 17 | 18 | #include "dynamic_vector_typedef.inc" 19 | 20 | contains 21 | 22 | #include "dynamic_vector_procdef.inc" 23 | 24 | end module dynamic_vector_int_ptr 25 | -------------------------------------------------------------------------------- /RandNum/src/dsfmt_f03/dSFMT_utils.c: -------------------------------------------------------------------------------- 1 | #include "dSFMT.h" 2 | #include 3 | 4 | /* copyright James Spencer 2012. 5 | * New BSD License, see License.txt for details. 6 | */ 7 | 8 | /* Utility (memory-access) functions to enable use of dSFMT from Fortran. */ 9 | 10 | void* malloc_dsfmt_t(void) { 11 | /* Allocate sufficient memory for a dSFMT state (ie a variable of type dsfmt_t). */ 12 | return malloc(sizeof(dsfmt_t)); 13 | } 14 | 15 | void free_dsfmt_t(dsfmt_t* ptr) { 16 | /* Free memory associated with a dSFMT state (ie a variable of type dsfmt_t). */ 17 | free(ptr); 18 | } 19 | -------------------------------------------------------------------------------- /test/unit/dynamic_vector/dynamic_vector_r8.F90: -------------------------------------------------------------------------------- 1 | module dynamic_vector_r8 2 | 3 | use shr_kind_mod, only: r8 => shr_kind_r8 4 | use shr_infnan_mod, only: assignment(=), nan => shr_infnan_nan 5 | 6 | use funit, only: throw 7 | 8 | use shr_log_mod, only: OOBMsg => shr_log_OOBMsg 9 | 10 | implicit none 11 | private 12 | 13 | #define VECTOR_NAME r8_vector 14 | #define TYPE_NAME real(r8) 15 | #define THROW(string) call throw(string) 16 | 17 | public :: VECTOR_NAME 18 | 19 | #include "dynamic_vector_typedef.inc" 20 | 21 | contains 22 | 23 | #include "dynamic_vector_procdef.inc" 24 | 25 | end module dynamic_vector_r8 26 | -------------------------------------------------------------------------------- /test/unit/shr_log_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set(pf_sources 2 | test_error_printers.pf) 3 | 4 | set(sources_needed shr_kind_mod.F90 shr_infnan_mod.F90 5 | shr_strconvert_mod.F90 shr_log_mod.F90) 6 | 7 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 8 | 9 | add_pfunit_ctest(shr_log 10 | TEST_SOURCES "${pf_sources}" 11 | OTHER_SOURCES "${test_sources}") 12 | 13 | declare_generated_dependencies(shr_log "${share_genf90_sources}") 14 | 15 | target_link_libraries(shr_log esmf) 16 | # The following adds all dependencies of ESMF, including PIO, NetCDF, etc.: 17 | target_link_libraries(shr_log ESMF::ESMF) 18 | -------------------------------------------------------------------------------- /test/unit/shr_vmath_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set(test_sources test_vmath.F90) 2 | 3 | set(sources_needed shr_kind_mod.F90 shr_log_mod.F90 shr_strconvert_mod.F90 4 | shr_infnan_mod.F90 shr_const_mod.F90 shr_vmath_mod.F90) 5 | 6 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 7 | 8 | add_executable(vmath_test_exe ${test_sources}) 9 | 10 | # Add the actual test. 11 | add_test(vmath vmath_test_exe) 12 | 13 | declare_generated_dependencies(vmath_test_exe "${share_genf90_sources}") 14 | 15 | target_link_libraries(vmath_test_exe esmf) 16 | # The following adds all dependencies of ESMF, including PIO, NetCDF, etc.: 17 | target_link_libraries(vmath_test_exe ESMF::ESMF) 18 | -------------------------------------------------------------------------------- /test/unit/dynamic_vector/integer_vector_tests.pf.in: -------------------------------------------------------------------------------- 1 | module integer_vector_tests 2 | ! Module to test dynamic vector template on 3 | ! integers. 4 | 5 | use funit 6 | 7 | use shr_log_mod, only: OOBMsg => shr_log_OOBMsg 8 | 9 | #define TYPE_NAME integer 10 | #define TYPE_DECL integer 11 | #define VECTOR_NAME integer_vector 12 | 13 | use dynamic_vector_integer, only: & 14 | integer_vector 15 | 16 | implicit none 17 | 18 | integer, parameter :: test_array(3) = [ 3, 2, 1 ] 19 | 20 | integer, parameter :: test_array_2(5) = [ 4, 5, 6, 7, 8 ] 21 | 22 | integer, parameter :: new_val = -1 23 | 24 | contains 25 | 26 | #include "dynamic_vector_base_tests.inc" 27 | 28 | end module integer_vector_tests 29 | -------------------------------------------------------------------------------- /test/unit/shr_assert_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set(pf_sources test_assert.pf test_assert_array.pf test_macro.pf 2 | test_ndebug.pf) 3 | 4 | set(sources_needed shr_kind_mod.F90 shr_infnan_mod.F90 5 | shr_strconvert_mod.F90 shr_log_mod.F90 6 | shr_sys_mod.nompi_abortthrows.F90 shr_abort_mod.abortthrows.F90 7 | shr_assert_mod.F90) 8 | 9 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 10 | 11 | add_pfunit_ctest(assert 12 | TEST_SOURCES "${pf_sources}" 13 | OTHER_SOURCES "${test_sources}") 14 | 15 | declare_generated_dependencies(assert "${share_genf90_sources}") 16 | 17 | target_link_libraries(assert esmf) 18 | # The following adds all dependencies of ESMF, including PIO, NetCDF, etc.: 19 | target_link_libraries(assert ESMF::ESMF) 20 | -------------------------------------------------------------------------------- /test/unit/dynamic_vector/r8_vector_tests.pf.in: -------------------------------------------------------------------------------- 1 | module r8_vector_tests 2 | ! Module to test dynamic vector template on reals. 3 | 4 | use funit 5 | 6 | use shr_log_mod, only: OOBMsg => shr_log_OOBMsg 7 | 8 | use shr_kind_mod, only: r8 => shr_kind_r8 9 | 10 | #define TYPE_NAME r8 11 | #define TYPE_DECL real(r8) 12 | #define VECTOR_NAME r8_vector 13 | 14 | use dynamic_vector_r8, only: & 15 | r8_vector 16 | 17 | implicit none 18 | 19 | real(r8), parameter :: test_array(3) = [ 1.2_r8, 2.3_r8, 6.4_r8 ] 20 | 21 | real(r8), parameter :: test_array_2(5) = & 22 | [ 6.2_r8, 6.7_r8, 3.4_r8, 7.8_r8, 3.4_r8 ] 23 | 24 | real(r8), parameter :: new_val = -1.8_r8 25 | 26 | contains 27 | 28 | #include "dynamic_vector_base_tests.inc" 29 | 30 | end module r8_vector_tests 31 | -------------------------------------------------------------------------------- /test/unit/shr_spfn_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set(pf_sources test_erf_r4.pf test_erf_r8.pf test_gamma_factorial.pf 2 | test_igamma.pf) 3 | 4 | set(sources_needed shr_kind_mod.F90 shr_const_mod.F90 shr_infnan_mod.F90 5 | shr_strconvert_mod.F90 shr_log_mod.F90 6 | shr_sys_mod.nompi_abortthrows.F90 shr_abort_mod.abortthrows.F90 7 | shr_spfn_mod.F90) 8 | 9 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 10 | 11 | add_pfunit_ctest(spfn 12 | TEST_SOURCES "${pf_sources}" 13 | OTHER_SOURCES "${test_sources}") 14 | 15 | declare_generated_dependencies(spfn "${share_genf90_sources}") 16 | 17 | target_link_libraries(spfn esmf) 18 | # The following adds all dependencies of ESMF, including PIO, NetCDF, etc.: 19 | target_link_libraries(spfn ESMF::ESMF) 20 | -------------------------------------------------------------------------------- /test/unit/shr_string_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set (pf_sources 2 | test_shr_string.pf 3 | ) 4 | 5 | set(sources_needed 6 | shr_string_mod.F90 7 | shr_assert_mod.F90 8 | shr_infnan_mod.F90 9 | shr_kind_mod.F90 10 | shr_log_mod.F90 11 | shr_strconvert_mod.F90 12 | shr_sys_mod.nompi_abortthrows.F90 13 | shr_abort_mod.abortthrows.F90 14 | shr_timer_mod.F90) 15 | 16 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 17 | 18 | add_pfunit_ctest(shr_string 19 | TEST_SOURCES "${pf_sources}" 20 | OTHER_SOURCES "${test_sources}") 21 | 22 | declare_generated_dependencies(shr_string "${share_genf90_sources}") 23 | 24 | target_link_libraries(shr_string esmf) 25 | # The following adds all dependencies of ESMF, including PIO, NetCDF, etc.: 26 | target_link_libraries(shr_string ESMF::ESMF) 27 | -------------------------------------------------------------------------------- /test/unit/dynamic_vector/ptr_wrapper.F90: -------------------------------------------------------------------------------- 1 | module ptr_wrapper 2 | 3 | ! This module simply defines a wrapper for integer pointers in order to 4 | ! test the dynamic_vector type on a derived type. 5 | 6 | implicit none 7 | private 8 | save 9 | 10 | public :: int_ptr 11 | 12 | type int_ptr 13 | integer, pointer :: p => null() 14 | contains 15 | procedure, pass(first) :: cmp => int_ptr_cmp 16 | generic :: operator(==) => cmp 17 | end type int_ptr 18 | 19 | contains 20 | 21 | elemental function int_ptr_cmp(first, second) result(is_same) 22 | class(int_ptr), intent(in) :: first 23 | class(int_ptr), intent(in) :: second 24 | logical :: is_same 25 | 26 | is_same = associated(first%p, second%p) .or. & 27 | (.not. associated(first%p) .and. .not. associated(second%p)) 28 | 29 | end function int_ptr_cmp 30 | 31 | end module ptr_wrapper 32 | -------------------------------------------------------------------------------- /src/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | set(genf90_files shr_assert_mod.F90.in shr_frz_mod.F90.in shr_infnan_mod.F90.in) 2 | 3 | process_genf90_source_list("${genf90_files}" ${CMAKE_CURRENT_BINARY_DIR} 4 | share_genf90_sources) 5 | 6 | sourcelist_to_parent(share_genf90_sources) 7 | 8 | # share_sources is currently just used for unit tests 9 | list(APPEND share_sources "${share_genf90_sources}") 10 | 11 | list(APPEND share_sources 12 | shr_file_mod.F90 13 | shr_kind_mod.F90 14 | shr_const_mod.F90 15 | shr_sys_mod.F90 16 | shr_log_mod.F90 17 | shr_orb_mod.F90 18 | shr_spfn_mod.F90 19 | shr_strconvert_mod.F90 20 | shr_cal_mod.F90 21 | shr_nl_mod.F90 22 | shr_precip_mod.F90 23 | shr_string_mod.F90 24 | shr_timer_mod.F90 25 | shr_vmath_mod.F90 26 | shr_mpi_mod.F90 27 | shr_pio_mod.F90 28 | shr_wv_sat_mod.F90 29 | m_MergeSorts.F90) 30 | 31 | sourcelist_to_parent(share_sources) 32 | 33 | -------------------------------------------------------------------------------- /test/unit/shr_abort_test/test_shr_abort.pf: -------------------------------------------------------------------------------- 1 | module test_shr_abort 2 | 3 | ! Tests of shr_abort_mod: version used in unit tests that throws a pfunit exception 4 | ! rather than aborting 5 | 6 | use funit 7 | use shr_abort_mod 8 | use shr_kind_mod , only : r8 => shr_kind_r8 9 | 10 | implicit none 11 | 12 | @TestCase 13 | type, extends(TestCase) :: TestShrAbort 14 | contains 15 | procedure :: setUp 16 | procedure :: tearDown 17 | end type TestShrAbort 18 | 19 | real(r8), parameter :: tol = 1.e-13_r8 20 | 21 | contains 22 | 23 | subroutine setUp(this) 24 | class(TestShrAbort), intent(inout) :: this 25 | end subroutine setUp 26 | 27 | subroutine tearDown(this) 28 | class(TestShrAbort), intent(inout) :: this 29 | end subroutine tearDown 30 | 31 | @Test 32 | subroutine test_abort(this) 33 | class(TestShrAbort), intent(inout) :: this 34 | 35 | call shr_abort_abort('Test message') 36 | @assertExceptionRaised('ABORTED: Test message') 37 | end subroutine test_abort 38 | 39 | end module test_shr_abort 40 | -------------------------------------------------------------------------------- /test/unit/shr_spfn_test/test_igamma.pf: -------------------------------------------------------------------------------- 1 | module test_igamma 2 | 3 | use funit 4 | 5 | use shr_kind_mod, only: & 6 | r8 => shr_kind_r8 7 | 8 | use shr_const_mod, only: & 9 | pi => shr_const_pi 10 | 11 | use shr_spfn_mod, only: & 12 | igamma => shr_spfn_igamma, & 13 | erfc => shr_spfn_erfc 14 | 15 | implicit none 16 | save 17 | 18 | real(r8), parameter :: relative_error_tolerance = 1.e-12_r8 19 | 20 | contains 21 | 22 | ! igamma(1,x) = exp(-x) 23 | ! => igamma(1,1) = exp(-1) 24 | @Test 25 | subroutine igamma_matches_exp_1() 26 | real(r8) :: tol 27 | tol = relative_error_tolerance*exp(-1._r8) 28 | @assertEqual(exp(-1._r8), igamma(1._r8, 1._r8), tolerance=tol) 29 | end subroutine igamma_matches_exp_1 30 | 31 | ! igamma(1/2,x) = sqrt(pi)*erfc(sqrt(x)) 32 | ! => igamma(0.5,1) = sqrt(pi)*erfc(1) 33 | @Test 34 | subroutine igamma_matches_erfc_1() 35 | real(r8) :: expected 36 | real(r8) :: tol 37 | expected = sqrt(pi)*erfc(1._r8) 38 | tol = relative_error_tolerance*expected 39 | @assertEqual(expected, igamma(0.5_r8, 1._r8), tolerance=tol) 40 | end subroutine igamma_matches_erfc_1 41 | 42 | end module test_igamma 43 | -------------------------------------------------------------------------------- /test/unit/shr_cal_test/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # Local pFUnit files. 2 | set(pf_sources 3 | test_shr_cal.pf) 4 | 5 | # Sources to test. 6 | set(sources_needed 7 | shr_cal_mod.F90 8 | shr_kind_mod.F90 9 | shr_const_mod.F90 10 | shr_sys_mod.nompi_abortthrows.F90 11 | shr_abort_mod.abortthrows.F90 12 | shr_string_mod.F90 13 | shr_strconvert_mod.F90 14 | shr_infnan_mod.F90 15 | shr_log_mod.F90 16 | shr_assert_mod.F90 17 | shr_timer_mod.F90) 18 | 19 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 20 | 21 | # This is needed to make ESMF_Stubs.F90 avoid pulling in mpi 22 | add_definitions(-DHIDE_MPI) 23 | 24 | # Do source preprocessing and add the executable. 25 | add_pfunit_ctest(shr_cal_mod 26 | TEST_SOURCES "${pf_sources}" 27 | OTHER_SOURCES "${test_sources}") 28 | 29 | declare_generated_dependencies(shr_cal_mod "${share_genf90_sources}") 30 | #set_target_properties(shr_cal_mod PROPERTIES LINK_FLAGS "${ESMF_F90ESMFLINKLIBS}") 31 | 32 | target_link_libraries(shr_cal_mod esmf pioc netcdff netcdf) 33 | # The following adds all dependencies of ESMF, including PIO, NetCDF, etc.: 34 | target_link_libraries(shr_cal_mod ESMF::ESMF) 35 | -------------------------------------------------------------------------------- /test/unit/mock/shr_sys_mod.nompi_abortthrows.F90: -------------------------------------------------------------------------------- 1 | module shr_sys_mod 2 | 3 | ! This is a mock version of shr_sys_mod. 4 | ! It contains only a few routines that are needed, and an abort method that throws a pFUnit 5 | ! exception instead of actually aborting. 6 | 7 | use shr_kind_mod, only: & 8 | shr_kind_in, shr_kind_r8 9 | 10 | use shr_abort_mod, only : shr_sys_abort => shr_abort_abort 11 | 12 | implicit none 13 | private 14 | save 15 | 16 | ! Fake abort 17 | ! Imported from shr_abort_mod and republished with renames. Other code that wishes to use 18 | ! these routines should use these shr_sys names rather than directly using the routines 19 | ! from shr_abort_abort. (This is for consistency with older code, from when these routines 20 | ! were defined in shr_sys_mod.) 21 | public :: shr_sys_abort 22 | 23 | ! Fake sleep 24 | public :: shr_sys_sleep 25 | 26 | ! Real flush 27 | public :: shr_sys_flush 28 | 29 | contains 30 | 31 | subroutine shr_sys_sleep(sec) 32 | real(shr_kind_r8), intent(in) :: sec 33 | 34 | ! do nothing 35 | end subroutine shr_sys_sleep 36 | 37 | SUBROUTINE shr_sys_flush(unit) 38 | 39 | !----- arguments ----- 40 | integer(SHR_KIND_IN) :: unit ! flush output buffer for this unit 41 | 42 | flush(unit) 43 | 44 | END SUBROUTINE shr_sys_flush 45 | 46 | end module shr_sys_mod 47 | -------------------------------------------------------------------------------- /src/shr_kind_mod.F90: -------------------------------------------------------------------------------- 1 | MODULE shr_kind_mod 2 | 3 | !---------------------------------------------------------------------------- 4 | ! precision/kind constants add data public 5 | !---------------------------------------------------------------------------- 6 | 7 | public 8 | integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real 9 | integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real 10 | integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real 11 | integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer 12 | integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer 13 | integer,parameter :: SHR_KIND_I2 = selected_int_kind ( 4) ! 2 byte integer 14 | integer,parameter :: SHR_KIND_IN = kind(1) ! native integer 15 | integer,parameter :: SHR_KIND_CS = 80 ! short char 16 | integer,parameter :: SHR_KIND_CM = 160 ! mid-sized char 17 | integer,parameter :: SHR_KIND_CL = 256 ! long char 18 | integer,parameter :: SHR_KIND_CX = 512 ! extra-long char 19 | integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char 20 | real(kind=shr_kind_r8),parameter :: tinyvalue = tiny(1._shr_kind_R8) ! tiny value 21 | real(kind=shr_kind_r8),parameter :: hugevalue = huge(1._shr_kind_r8) ! huge value 22 | END MODULE shr_kind_mod 23 | -------------------------------------------------------------------------------- /include/shr_assert.h: -------------------------------------------------------------------------------- 1 | #ifdef NDEBUG 2 | #define SHR_ASSERT(assert, msg) 3 | #define SHR_ASSERT_FL(assert, file, line) 4 | #define SHR_ASSERT_MFL(assert, msg, file, line) 5 | #define SHR_ASSERT_ALL(assert, msg) 6 | #define SHR_ASSERT_ALL_FL(assert, file, line) 7 | #define SHR_ASSERT_ALL_MFL(assert, msg, file, line) 8 | #define SHR_ASSERT_ANY(assert, msg) 9 | #define SHR_ASSERT_ANY_FL(assert, file, line) 10 | #define SHR_ASSERT_ANY_MFL(assert, msg, file, line) 11 | #else 12 | #define SHR_ASSERT(assert, my_msg) call shr_assert(assert, msg=my_msg) 13 | #define SHR_ASSERT_FL(assert, my_file, my_line) call shr_assert(assert, file=my_file, line=my_line) 14 | #define SHR_ASSERT_MFL(assert, my_msg, my_file, my_line) call shr_assert(assert, msg=my_msg, file=my_file, line=my_line) 15 | #define SHR_ASSERT_ALL(assert, my_msg) call shr_assert_all(assert, msg=my_msg) 16 | #define SHR_ASSERT_ALL_FL(assert, my_file, my_line) call shr_assert_all(assert, file=my_file, line=my_line) 17 | #define SHR_ASSERT_ALL_MFL(assert, my_msg, my_file, my_line) call shr_assert_all(assert, msg=my_msg, file=my_file, line=my_line) 18 | #define SHR_ASSERT_ANY(assert, my_msg) call shr_assert_any(assert, msg=my_msg) 19 | #define SHR_ASSERT_ANY_FL(assert, my_file, my_line) call shr_assert_any(assert, file=my_file, line=my_line) 20 | #define SHR_ASSERT_ANY_MFL(assert, my_msg, my_file, my_line) call shr_assert_any(assert, msg=my_msg, file=my_file, line=my_line) 21 | #endif 22 | use shr_assert_mod 23 | -------------------------------------------------------------------------------- /RandNum/src/kissvec/kissvec.c: -------------------------------------------------------------------------------- 1 | // KISS random generator implemented in C 2 | // Basic algorithm from George Marsaglia circa 1998 3 | // Public domain Fortran implementation from http://www.fortran.com/ 4 | // downloaded by pjr on 03/16/04 5 | // converted to vector form, functions inlined by pjr,mvr on 05/10/2004 6 | // Translated back into C in 2015 7 | 8 | #include 9 | #include 10 | 11 | #define shiftl_xor(x, n) (x ^= (x << n)) 12 | #define shiftr_xor(x, n) (x ^= (x >> n)) 13 | 14 | // The KISS (Keep It Simple Stupid) random number generator. Combines: 15 | // (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. 16 | // (2) A 3-shift shift-register generator, period 2^32-1, 17 | // (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 18 | // Overall period>2^123; 19 | // 20 | // Note use of the C99 restrict keyword to enable optimization. 21 | void kiss_rng(uint32_t seed1[restrict], uint32_t seed2[restrict], 22 | uint32_t seed3[restrict], uint32_t seed4[restrict], 23 | double ran_arr[restrict], size_t length) { 24 | size_t i; 25 | 26 | for (i = 0; i < length; ++i) { 27 | seed1[i] = 69069U * seed1[i] + 1327217885U; 28 | shiftl_xor(seed2[i], 13); 29 | shiftr_xor(seed2[i], 17); 30 | shiftl_xor(seed2[i], 5); 31 | seed3[i] = 18000U * (seed3[i] & 65535U) + (seed3[i] >> 16); 32 | seed4[i] = 30903U * (seed4[i] & 65535U) + (seed4[i] >> 16); 33 | ran_arr[i] = ((int32_t) (seed1[i] + seed2[i] + (seed3[i] << 16) + seed4[i])) * 2.328306E-10 + 0.5; 34 | } 35 | 36 | } 37 | -------------------------------------------------------------------------------- /RandNum/include/dSFMT-params19937.h: -------------------------------------------------------------------------------- 1 | #ifndef DSFMT_PARAMS19937_H 2 | #define DSFMT_PARAMS19937_H 3 | 4 | /* #define DSFMT_N 191 */ 5 | /* #define DSFMT_MAXDEGREE 19992 */ 6 | #define DSFMT_POS1 117 7 | #define DSFMT_SL1 19 8 | #define DSFMT_MSK1 UINT64_C(0x000ffafffffffb3f) 9 | #define DSFMT_MSK2 UINT64_C(0x000ffdfffc90fffd) 10 | #define DSFMT_MSK32_1 0x000ffaffU 11 | #define DSFMT_MSK32_2 0xfffffb3fU 12 | #define DSFMT_MSK32_3 0x000ffdffU 13 | #define DSFMT_MSK32_4 0xfc90fffdU 14 | #define DSFMT_FIX1 UINT64_C(0x90014964b32f4329) 15 | #define DSFMT_FIX2 UINT64_C(0x3b8d12ac548a7c7a) 16 | #define DSFMT_PCV1 UINT64_C(0x3d84e1ac0dc82880) 17 | #define DSFMT_PCV2 UINT64_C(0x0000000000000001) 18 | #define DSFMT_IDSTR "dSFMT2-19937:117-19:ffafffffffb3f-ffdfffc90fffd" 19 | 20 | 21 | /* PARAMETERS FOR ALTIVEC */ 22 | #if defined(__APPLE__) /* For OSX */ 23 | #define ALTI_SL1 (vector unsigned int)(3, 3, 3, 3) 24 | #define ALTI_SL1_PERM \ 25 | (vector unsigned char)(2,3,4,5,6,7,30,30,10,11,12,13,14,15,0,1) 26 | #define ALTI_SL1_MSK \ 27 | (vector unsigned int)(0xffffffffU,0xfff80000U,0xffffffffU,0xfff80000U) 28 | #define ALTI_MSK (vector unsigned int)(DSFMT_MSK32_1, \ 29 | DSFMT_MSK32_2, DSFMT_MSK32_3, DSFMT_MSK32_4) 30 | #else /* For OTHER OSs(Linux?) */ 31 | #define ALTI_SL1 {3, 3, 3, 3} 32 | #define ALTI_SL1_PERM \ 33 | {2,3,4,5,6,7,30,30,10,11,12,13,14,15,0,1} 34 | #define ALTI_SL1_MSK \ 35 | {0xffffffffU,0xfff80000U,0xffffffffU,0xfff80000U} 36 | #define ALTI_MSK \ 37 | {DSFMT_MSK32_1, DSFMT_MSK32_2, DSFMT_MSK32_3, DSFMT_MSK32_4} 38 | #endif 39 | 40 | #endif /* DSFMT_PARAMS19937_H */ 41 | -------------------------------------------------------------------------------- /RandNum/src/kissvec/kissvec_mod.F90: -------------------------------------------------------------------------------- 1 | module kissvec_mod 2 | ! Fortran binding for the KISS vectorizable random number generator. 3 | 4 | implicit none 5 | 6 | integer, parameter :: r8 = selected_real_kind(12) 7 | 8 | private 9 | public :: kissvec 10 | 11 | contains 12 | 13 | subroutine kissvec( seed1, seed2, seed3, seed4, ran_arr, length) 14 | 15 | ! We can assume that an r8 is a double and an i4 is an int32_t, but we can't 16 | ! make any guarantees about the relative sizes of a Fortran default integer 17 | ! and C's size_t. 18 | use iso_c_binding, only: c_size_t 19 | 20 | integer, intent(in) :: length 21 | real(r8), dimension(length), intent(inout) :: ran_arr 22 | integer, dimension(length), intent(inout) :: seed1, seed2, seed3, seed4 23 | 24 | ! C implementation 25 | interface 26 | subroutine kiss_rng(seed1, seed2, seed3, seed4, ran_arr, length) bind(c) 27 | ! Note that the definition of kiss_rng uses unsigned int, but the 28 | ! Fortran standard largely ignores signed/unsigned because there 29 | ! are no unsigned integers in Fortran. 30 | use iso_c_binding, only: c_int32_t, c_double, c_size_t 31 | integer(c_int32_t), intent(inout) :: seed1(*), seed2(*), seed3(*), seed4(*) 32 | real(c_double), intent(inout) :: ran_arr(*) 33 | integer(c_size_t), value :: length 34 | end subroutine kiss_rng 35 | end interface 36 | 37 | call kiss_rng(seed1, seed2, seed3, seed4, ran_arr, int(length, c_size_t)) 38 | 39 | end subroutine kissvec 40 | 41 | end module kissvec_mod 42 | -------------------------------------------------------------------------------- /test/unit/shr_log_test/test_error_printers.pf: -------------------------------------------------------------------------------- 1 | module test_error_printers 2 | 3 | use funit 4 | 5 | ! Tests for routines that create error messages. We obviously can't automate the 6 | ! process of deciding whether a message is correct or helpful, but we can test 7 | ! that the information provided is actually put into the output. 8 | 9 | use shr_kind_mod, only: cx => shr_kind_cx 10 | 11 | use shr_strconvert_mod, only: toString 12 | 13 | implicit none 14 | 15 | contains 16 | 17 | @Test 18 | subroutine errMsg_prints_arguments() 19 | use shr_log_mod, only: shr_log_errMsg 20 | 21 | character(len=*), parameter :: file_name = "foo.F90" 22 | integer, parameter :: line_no = 20 23 | 24 | character(len=cx) :: error_string 25 | 26 | error_string = shr_log_errMsg(file_name, line_no) 27 | 28 | @assertLessThan(0, index(error_string, file_name)) 29 | @assertLessThan(0, index(error_string, toString(line_no))) 30 | 31 | end subroutine errMsg_prints_arguments 32 | 33 | @Test 34 | subroutine OOBMsg_prints_arguments() 35 | use shr_log_mod, only: shr_log_OOBMsg 36 | 37 | character(len=*), parameter :: operation = "foo" 38 | integer, parameter :: bounds(2) = [2, 3], idx = 5 39 | 40 | character(len=cx) :: error_string 41 | 42 | error_string = shr_log_OOBMsg(operation, bounds, idx) 43 | 44 | @assertLessThan(0, index(error_string, operation)) 45 | @assertLessThan(0, index(error_string, toString(bounds(1)))) 46 | @assertLessThan(0, index(error_string, toString(bounds(2)))) 47 | @assertLessThan(0, index(error_string, toString(idx))) 48 | 49 | end subroutine OOBMsg_prints_arguments 50 | 51 | end module test_error_printers 52 | -------------------------------------------------------------------------------- /src/shr_precip_mod.F90: -------------------------------------------------------------------------------- 1 | module shr_precip_mod 2 | 3 | ! This module contains methods for manipulating precipitation quantities 4 | 5 | use shr_kind_mod, only : r8 => SHR_KIND_R8 6 | 7 | implicit none 8 | private 9 | save 10 | 11 | ! determine a rain-snow partitioning using a ramp method based on temperature 12 | public :: shr_precip_partition_rain_snow_ramp 13 | 14 | contains 15 | 16 | !----------------------------------------------------------------------- 17 | subroutine shr_precip_partition_rain_snow_ramp(temperature, frac_rain) 18 | ! 19 | ! !DESCRIPTION: 20 | ! Determine a rain-snow partitioning using a ramp method based on temperature. 21 | ! 22 | ! Returns fractional mass of precipitation falling as rain. The rest (1 - frac_rain) 23 | ! falls as snow. 24 | ! 25 | ! This is meant to be used for precipitation at the surface, e.g., to force CLM. 26 | ! 27 | ! !USES: 28 | use shr_const_mod, only : SHR_CONST_TKFRZ 29 | ! 30 | ! !ARGUMENTS: 31 | real(r8), intent(in) :: temperature ! temperature (K) 32 | real(r8), intent(out) :: frac_rain ! fraction of precipitation falling as rain 33 | ! 34 | ! !LOCAL VARIABLES: 35 | 36 | character(len=*), parameter :: subname = 'shr_precip_partition_rain_snow_ramp' 37 | !----------------------------------------------------------------------- 38 | 39 | ! ramp near freezing 40 | frac_rain = (temperature - SHR_CONST_TKFRZ) * 0.5_r8 41 | 42 | ! bound in [0,1] 43 | frac_rain = min(1.0_r8,max(0.0_r8,frac_rain)) 44 | 45 | end subroutine shr_precip_partition_rain_snow_ramp 46 | 47 | end module shr_precip_mod 48 | -------------------------------------------------------------------------------- /cmake/FindMPISERIAL.cmake: -------------------------------------------------------------------------------- 1 | # - Try to find MPISERIAL 2 | # 3 | # This can be controlled by setting the MPISERIAL_PATH (or, equivalently, the 4 | # MPISERIAL environment variable). 5 | # 6 | # Once done, this will define: 7 | # 8 | # MPISERIAL_FOUND (BOOL) - system has MPISERIAL 9 | # MPISERIAL_IS_SHARED (BOOL) - whether library is shared/dynamic 10 | # MPISERIAL_INCLUDE_DIR (PATH) - Location of the C header file 11 | # MPISERIAL_INCLUDE_DIRS (LIST) - the MPISERIAL include directories 12 | # MPISERIAL_LIBRARY (FILE) - Path to the C library file 13 | # MPISERIAL_LIBRARIES (LIST) - link these to use MPISERIAL 14 | # 15 | include (LibFind) 16 | 17 | # Define MPISERIAL C component 18 | define_package_component (MPISERIAL DEFAULT 19 | COMPONENT C 20 | INCLUDE_NAMES mpi.h 21 | LIBRARY_NAMES mpi-serial) 22 | 23 | # Define MPISERIAL Fortran component 24 | define_package_component (MPISERIAL 25 | COMPONENT Fortran 26 | INCLUDE_NAMES mpi.mod mpif.h 27 | LIBRARY_NAMES mpi-serial) 28 | 29 | # Search for list of valid components requested 30 | find_valid_components (MPISERIAL) 31 | 32 | #============================================================================== 33 | # SEARCH FOR VALIDATED COMPONENTS 34 | foreach (MPISERIAL_comp IN LISTS MPISERIAL_FIND_VALID_COMPONENTS) 35 | 36 | # If not found already, search... 37 | if (NOT MPISERIAL_${MPISERIAL_comp}_FOUND) 38 | 39 | # Search for the package 40 | find_package_component(MPISERIAL COMPONENT ${MPISERIAL_comp}) 41 | 42 | endif () 43 | 44 | endforeach () 45 | -------------------------------------------------------------------------------- /test/unit/shr_assert_test/test_assert.pf: -------------------------------------------------------------------------------- 1 | module test_assert 2 | 3 | ! Test basic assert functionality. 4 | 5 | use funit 6 | 7 | use shr_assert_mod, only: & 8 | shr_assert, & 9 | shr_assert_all, & 10 | shr_assert_any 11 | 12 | implicit none 13 | save 14 | 15 | contains 16 | 17 | @Test 18 | subroutine assert_can_pass() 19 | call shr_assert(.true., "Assert unexpectedly aborted!") 20 | end subroutine assert_can_pass 21 | 22 | @Test 23 | subroutine assert_can_fail() 24 | call shr_assert(.false., "Expected failure.") 25 | call assertExceptionRaised("ABORTED: ERROR: Expected failure.") 26 | end subroutine assert_can_fail 27 | 28 | @Test 29 | subroutine assert_prints_file_and_line() 30 | call shr_assert(.false., "Expected failure.", file='foo', line=42) 31 | call assertExceptionRaised("ABORTED: ERROR in foo at line 42: Expected failure.") 32 | end subroutine assert_prints_file_and_line 33 | 34 | @Test 35 | subroutine assert_all_scalar_can_pass() 36 | call shr_assert_all(.true., "Assert unexpectedly aborted!") 37 | end subroutine assert_all_scalar_can_pass 38 | 39 | @Test 40 | subroutine assert_all_scalar_can_fail() 41 | call shr_assert_all(.false., "Expected failure.") 42 | call assertExceptionRaised("ABORTED: ERROR: Expected failure.") 43 | end subroutine assert_all_scalar_can_fail 44 | 45 | @Test 46 | subroutine assert_any_scalar_can_pass() 47 | call shr_assert_any(.true., "Assert unexpectedly aborted!") 48 | end subroutine assert_any_scalar_can_pass 49 | 50 | @Test 51 | subroutine assert_any_scalar_can_fail() 52 | call shr_assert_any(.false., "Expected failure.") 53 | call assertExceptionRaised("ABORTED: ERROR: Expected failure.") 54 | end subroutine assert_any_scalar_can_fail 55 | 56 | end module test_assert 57 | -------------------------------------------------------------------------------- /test/unit/shr_precip_test/test_shr_precip.pf: -------------------------------------------------------------------------------- 1 | module test_shr_precip 2 | 3 | ! Tests of shr_precip_mod 4 | 5 | use funit 6 | use shr_precip_mod 7 | use shr_kind_mod, only : r8 => SHR_KIND_R8 8 | use shr_const_mod, only : SHR_CONST_TKFRZ 9 | 10 | implicit none 11 | 12 | @TestCase 13 | type, extends(TestCase) :: TestShrPrecip 14 | contains 15 | procedure :: setUp 16 | procedure :: tearDown 17 | end type TestShrPrecip 18 | 19 | real(r8), parameter :: tol = 1.e-13_r8 20 | 21 | contains 22 | 23 | subroutine setUp(this) 24 | class(TestShrPrecip), intent(inout) :: this 25 | end subroutine setUp 26 | 27 | subroutine tearDown(this) 28 | class(TestShrPrecip), intent(inout) :: this 29 | end subroutine tearDown 30 | 31 | ! ------------------------------------------------------------------------ 32 | ! Tests of shr_precip_partition_rain_snow_ramp 33 | ! ------------------------------------------------------------------------ 34 | 35 | @Test 36 | subroutine partition_rain_snow_ramp_allSnow(this) 37 | class(TestShrPrecip), intent(inout) :: this 38 | real(r8) :: frac_rain 39 | 40 | call shr_precip_partition_rain_snow_ramp(273._r8, frac_rain) 41 | @assertEqual(0._r8, frac_rain) 42 | end subroutine partition_rain_snow_ramp_allSnow 43 | 44 | @Test 45 | subroutine partition_rain_snow_ramp_allRain(this) 46 | class(TestShrPrecip), intent(inout) :: this 47 | real(r8) :: frac_rain 48 | 49 | call shr_precip_partition_rain_snow_ramp(276._r8, frac_rain) 50 | @assertEqual(1._r8, frac_rain) 51 | end subroutine partition_rain_snow_ramp_allRain 52 | 53 | @Test 54 | subroutine partition_rain_snow_ramp_mixture(this) 55 | class(TestShrPrecip), intent(inout) :: this 56 | real(r8) :: frac_rain 57 | 58 | call shr_precip_partition_rain_snow_ramp(SHR_CONST_TKFRZ + 1.5_r8, frac_rain) 59 | @assertEqual(0.75_r8, frac_rain, tolerance=tol) 60 | end subroutine partition_rain_snow_ramp_mixture 61 | 62 | end module test_shr_precip 63 | -------------------------------------------------------------------------------- /test/unit/dynamic_vector/character16_vector_tests.pf.in: -------------------------------------------------------------------------------- 1 | module character16_vector_tests 2 | ! Module to test dynamic vector template on 3 | ! character strings. 4 | 5 | use funit 6 | 7 | use shr_log_mod, only: OOBMsg => shr_log_OOBMsg 8 | 9 | #define TYPE_NAME character16 10 | #define TYPE_DECL character(len=16) 11 | #define VECTOR_NAME character16_vector 12 | use dynamic_vector_character16, only: & 13 | character16_vector 14 | 15 | implicit none 16 | 17 | character(len=16), parameter :: test_array(3) = [ & 18 | "Alice ", & 19 | "Bob ", & 20 | "Charlie " ] 21 | 22 | character(len=16), parameter :: test_array_2(5) = [& 23 | "David ", & 24 | "Eve ", & 25 | "Fred ", & 26 | "Georgia ", & 27 | "Hank " ] 28 | 29 | character(len=16), parameter :: new_val = "Irene " 30 | 31 | interface assertEqual 32 | module procedure assertEqualString_0D_1D 33 | module procedure assertEqualString_1D_1D 34 | end interface 35 | 36 | contains 37 | 38 | ! pFUnit doesn't have assertEqual routines for arrays of strings. 39 | subroutine assertEqualString_0D_1D(expected, found, message, location) 40 | character(len=*), intent(in) :: expected 41 | character(len=*), intent(in) :: found(:) 42 | character(len=*), optional, intent(in) :: message 43 | type (SourceLocation), optional, intent(in) :: location 44 | 45 | call assertAll(expected == found, message, location) 46 | 47 | end subroutine assertEqualString_0D_1D 48 | 49 | subroutine assertEqualString_1D_1D(expected, found, message, location) 50 | character(len=*), intent(in) :: expected(:) 51 | character(len=*), intent(in) :: found(:) 52 | character(len=*), optional, intent(in) :: message 53 | type (SourceLocation), optional, intent(in) :: location 54 | 55 | call assertAll(expected == found, message, location) 56 | 57 | end subroutine assertEqualString_1D_1D 58 | 59 | #include "dynamic_vector_base_tests.inc" 60 | 61 | end module character16_vector_tests 62 | -------------------------------------------------------------------------------- /.github/actions/buildshare/action.yaml: -------------------------------------------------------------------------------- 1 | name: SHARE build and cache 2 | description: 'Build the SHARE library' 3 | inputs: 4 | share_version: 5 | description: 'Tag in the SHARE repository to use' 6 | default: main 7 | required: False 8 | type: string 9 | cime_path: 10 | description: 'Path to CIME repository' 11 | default: $GITHUB_WORKSPACE/cime 12 | required: False 13 | type: string 14 | pio_path: 15 | description: 'Path to the installed parallelio code root' 16 | default: $HOME/pio 17 | required: False 18 | type: string 19 | esmfmkfile: 20 | description: 'Path to the installed ESMF library mkfile' 21 | default: $HOME/ESMF/lib/libg/Linux.gfortran.64.openmpi.default/esmf.mk 22 | required: False 23 | type: string 24 | pfunit_root: 25 | description: 'Path to installed pfunit library' 26 | default: $GITHUB_WORKSPACE/pfunit 27 | required: False 28 | type: string 29 | src_root: 30 | description: 'Path to share source' 31 | default: $GITHUB_WORKSPACE 32 | required: False 33 | type: string 34 | cmake_flags: 35 | description: 'Extra flags for cmake command' 36 | default: -Wno-dev 37 | required: False 38 | type: string 39 | install_prefix: 40 | description: 'Install path of share' 41 | default: $HOME/share 42 | required: False 43 | type: string 44 | runs: 45 | using: composite 46 | steps: 47 | - id : Build-SHARE 48 | shell: bash 49 | run: | 50 | mkdir build-share 51 | pushd build-share 52 | # this is machine specific 53 | export LDFLAGS="-L/usr/lib/x86_64-linux-gnu -lnetcdf -lnetcdff -lpnetcdf -Wl,--unresolved-symbols=ignore-all" 54 | export PFUNIT_DIR=${{ inputs.pfunit_root }}/build 55 | export ESMFMKFILE=${{ inputs.esmfmkfile }} 56 | export PIO_ROOT=${{ inputs.pio_path }} 57 | cmake -DCIME_CMAKE_MODULE_DIRECTORY=${{ inputs.cime_path }}/CIME/non_py/src/CMake -DCMAKE_PROGRAM_PATH=${{ inputs.cime_path }}/CIME/non_py/externals/genf90 ${{ inputs.cmake_flags }} ${{ inputs.src_root }} 58 | make VERBOSE=1 59 | popd 60 | -------------------------------------------------------------------------------- /src/shr_reprosumx86.c: -------------------------------------------------------------------------------- 1 | /* 2 | * src/x86.c 3 | * 4 | * This work was supported by the Director, Office of Science, Division 5 | * of Mathematical, Information, and Computational Sciences of the 6 | * U.S. Department of Energy under contract number DE-AC03-76SF00098. 7 | * 8 | * Copyright (c) 2000-2001 9 | * 10 | * Contains functions to set and restore the round-to-double flag in the 11 | * control word of a x86 FPU. 12 | */ 13 | 14 | #define _NO_CHANGE 0 15 | #define _UPPER_CASE 1 16 | #define _ADD_UNDERSCORE 2 17 | #define _ADD_TWO_UNDERSCORES 3 18 | 19 | #ifdef FORTRANUNDERSCORE 20 | #define NAMING _ADD_UNDERSCORE 21 | #endif 22 | 23 | #ifdef FORTRANDOUBLEUNDERSCORE 24 | #define NAMING _ADD_TWO_UNDERSCORES 25 | #endif 26 | 27 | #ifdef FORTRANCAPS 28 | #define NAMING _UPPER_CASE 29 | #endif 30 | 31 | #ifndef NAMING 32 | #define NAMING _NO_CHANGE 33 | #endif 34 | 35 | #if (NAMING == _ADD_UNDERSCORE) 36 | #define shr_reprosumx86_fix_start shr_reprosumx86_fix_start_ 37 | #define shr_reprosumx86_fix_end shr_reprosumx86_fix_end_ 38 | #endif 39 | 40 | #if (NAMING == _ADD_TWO_UNDERSCORES) 41 | #define shr_reprosumx86_fix_start shr_reprosumx86_fix_start__ 42 | #define shr_reprosumx86_fix_end shr_reprosumx86_fix_end__ 43 | #endif 44 | 45 | #if (NAMING == _UPPER_CASE) 46 | #define shr_reprosumx86_fix_start SHR_REPROSUMX86_FIX_START 47 | #define shr_reprosumx86_fix_end SHR_REPROSUMX86_FIX_END 48 | #endif 49 | 50 | #ifdef x86 51 | #ifndef _FPU_GETCW 52 | #define _FPU_GETCW(x) asm volatile ("fnstcw %0":"=m" (x)); 53 | #endif 54 | 55 | #ifndef _FPU_SETCW 56 | #define _FPU_SETCW(x) asm volatile ("fldcw %0": :"m" (x)); 57 | #endif 58 | 59 | #ifndef _FPU_EXTENDED 60 | #define _FPU_EXTENDED 0x0300 61 | #endif 62 | 63 | #ifndef _FPU_DOUBLE 64 | #define _FPU_DOUBLE 0x0200 65 | #endif 66 | #endif /* x86 */ 67 | 68 | void shr_reprosumx86_fix_start(unsigned short *old_cw) { 69 | #ifdef x86 70 | unsigned short new_cw; 71 | 72 | _FPU_GETCW(*old_cw); 73 | new_cw = (*old_cw & ~_FPU_EXTENDED) | _FPU_DOUBLE; 74 | _FPU_SETCW(new_cw); 75 | #endif 76 | } 77 | 78 | void shr_reprosumx86_fix_end(unsigned short *old_cw) { 79 | #ifdef x86 80 | _FPU_SETCW(*old_cw); 81 | #endif 82 | } 83 | -------------------------------------------------------------------------------- /LICENSE.TXT: -------------------------------------------------------------------------------- 1 | Copyright (c) 2021, University Corporation for Atmospheric Research (UCAR) 2 | All rights reserved. 3 | 4 | Developed by: 5 | University Corporation for Atmospheric Research - National Center for Atmospheric Research 6 | https://www2.cesm.ucar.edu/working-groups/sewg 7 | and 8 | DOE BER E3SM project team members, including those at SNL and ANL 9 | 10 | Permission is hereby granted, free of charge, to any person obtaining 11 | a copy of this software and associated documentation files (the "Software"), 12 | to deal with the Software without restriction, including without limitation 13 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 14 | and/or sell copies of the Software, and to permit persons to whom 15 | the Software is furnished to do so, subject to the following conditions: 16 | 17 | - Redistributions of source code must retain the above copyright notice, 18 | this list of conditions and the following disclaimers. 19 | - Redistributions in binary form must reproduce the above copyright notice, 20 | this list of conditions and the following disclaimers in the documentation 21 | and/or other materials provided with the distribution. 22 | - Neither the names of UCAR or Sandia Corporation, 23 | nor the names of its contributors may be used to endorse or promote 24 | products derived from this Software without specific prior written permission. 25 | 26 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 27 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 28 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 29 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE 30 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 31 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 32 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 33 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 34 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 35 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 36 | POSSIBILITY OF SUCH DAMAGE. 37 | -------------------------------------------------------------------------------- /unit_test_stubs/util/shr_abort_mod.abortthrows.F90: -------------------------------------------------------------------------------- 1 | module shr_abort_mod 2 | 3 | ! This is a replacement for shr_abort_mod that throws a pfunit exception rather than 4 | ! aborting 5 | 6 | use shr_kind_mod, only : shr_kind_in 7 | use funit, only : throw 8 | 9 | implicit none 10 | private 11 | 12 | public :: shr_abort_abort ! Replacement for shr_abort_abort that throws a pfunit exception rather than aborting 13 | 14 | public :: shr_abort_backtrace ! Just to satisfy the public interface of shr_abort_abort 15 | 16 | contains 17 | 18 | subroutine shr_abort_abort(string,rc, line, file) 19 | ! Replacement for shr_abort_abort that throws a pfunit exception rather than aborting 20 | ! 21 | ! This can be used to test expected errors (i.e., failure testing). 22 | ! 23 | ! If this occurs within a pFUnit-based test: 24 | ! 25 | ! - If you have code like: 26 | ! 27 | ! @assertExceptionRaised(expected_message) 28 | ! 29 | ! then your test will pass if the actual message in the 'throw' call (including the 30 | ! 'ABORTED: ' prefix) matches expected_message; it will fail if the actual message 31 | ! doesn't match the expected message 32 | ! 33 | ! - If you don't have 34 | ! 35 | ! @assertExceptionRaised 36 | ! 37 | ! or 38 | ! 39 | ! call assertExceptionRaised 40 | ! 41 | ! then this will result in the given pFUnit test failing. 42 | 43 | !----- arguments ----- 44 | character(len=*) , intent(in), optional :: string ! error message string 45 | integer(shr_kind_in), intent(in), optional :: rc ! error code 46 | integer(shr_kind_in), intent(in), optional :: line ! Line number in file (not used) 47 | character(len=*), intent(in), optional :: file ! Fielename (not used) 48 | 49 | !----- locals ----- 50 | integer(shr_kind_in) :: my_rc 51 | 52 | ! Prevent compiler spam about unused variables. 53 | if (.false.) my_rc = rc 54 | 55 | call throw("ABORTED: "//trim(string)) 56 | end subroutine shr_abort_abort 57 | 58 | subroutine shr_abort_backtrace() 59 | ! Just to satisfy the public interface of shr_abort_abort 60 | ! 61 | ! Does nothing 62 | 63 | end subroutine shr_abort_backtrace 64 | 65 | end module shr_abort_mod 66 | -------------------------------------------------------------------------------- /test/unit/shr_assert_test/test_ndebug.pf: -------------------------------------------------------------------------------- 1 | module test_ndebug 2 | 3 | ! Test that if NDEBUG is defined, shr_assert macros do nothing. 4 | 5 | use funit 6 | 7 | #define NDEBUG 8 | #include "shr_assert.h" 9 | 10 | contains 11 | 12 | logical function unreachable_function(macro_name) 13 | character(len=*), intent(in) :: macro_name 14 | 15 | call throw("NDEBUG failed to turn off " // macro_name) 16 | end function unreachable_function 17 | 18 | @Test 19 | subroutine ndebug_controls_assert_macro() 20 | SHR_ASSERT(unreachable_function("SHR_ASSERT"), "Fake message.") 21 | end subroutine ndebug_controls_assert_macro 22 | 23 | @Test 24 | subroutine ndebug_controls_assert_fl_macro() 25 | SHR_ASSERT_FL(unreachable_function("SHR_ASSERT_FL"), "my_file", 42) 26 | end subroutine ndebug_controls_assert_fl_macro 27 | 28 | @Test 29 | subroutine ndebug_controls_assert_mfl_macro() 30 | SHR_ASSERT_MFL(unreachable_function("SHR_ASSERT_MFL"), "Fake message.", "my_file", 42) 31 | end subroutine ndebug_controls_assert_mfl_macro 32 | 33 | @Test 34 | subroutine ndebug_controls_assert_all_macro() 35 | SHR_ASSERT_ALL(unreachable_function("SHR_ASSERT_ALL"), "Fake message.") 36 | end subroutine ndebug_controls_assert_all_macro 37 | 38 | @Test 39 | subroutine ndebug_controls_assert_all_fl_macro() 40 | SHR_ASSERT_ALL_FL(unreachable_function("SHR_ASSERT_ALL_FL"), "my_file", 42) 41 | end subroutine ndebug_controls_assert_all_fl_macro 42 | 43 | @Test 44 | subroutine ndebug_controls_assert_all_mfl_macro() 45 | SHR_ASSERT_ALL_MFL(unreachable_function("SHR_ASSERT_ALL_MFL"), "Fake message.", "my_file", 42) 46 | end subroutine ndebug_controls_assert_all_mfl_macro 47 | 48 | @Test 49 | subroutine ndebug_controls_assert_any_macro() 50 | SHR_ASSERT_ANY(unreachable_function("SHR_ASSERT_ANY"), "Fake message.") 51 | end subroutine ndebug_controls_assert_any_macro 52 | 53 | @Test 54 | subroutine ndebug_controls_assert_any_fl_macro() 55 | SHR_ASSERT_ANY_FL(unreachable_function("SHR_ASSERT_ANY_FL"), "my_file", 42) 56 | end subroutine ndebug_controls_assert_any_fl_macro 57 | 58 | @Test 59 | subroutine ndebug_controls_assert_any_mfl_macro() 60 | SHR_ASSERT_ANY_MFL(unreachable_function("SHR_ASSERT_ANY_MFL"), "Fake message.", "my_file", 42) 61 | end subroutine ndebug_controls_assert_any_mfl_macro 62 | 63 | end module test_ndebug 64 | -------------------------------------------------------------------------------- /test/unit/shr_spfn_test/test_gamma_factorial.pf: -------------------------------------------------------------------------------- 1 | module test_gamma_factorial 2 | 3 | use funit 4 | 5 | use shr_kind_mod, only: & 6 | r8 => shr_kind_r8, & 7 | i8 => shr_kind_i8 8 | 9 | use shr_spfn_mod, only: & 10 | gamma => shr_spfn_gamma, & 11 | igamma => shr_spfn_igamma 12 | 13 | implicit none 14 | save 15 | 16 | real(r8), parameter :: relative_error_tolerance = 1.e-12_r8 17 | 18 | @TestParameter 19 | type, extends(AbstractTestParameter) :: GammaTestInt 20 | integer :: test_int 21 | contains 22 | procedure :: toString 23 | end type GammaTestInt 24 | 25 | @TestCase(testParameters={getParameters()}, constructor=new_TestGammaFac) 26 | type, extends(ParameterizedTestCase) :: TestGammaFac 27 | real(r8) :: input_int 28 | real(r8) :: test_factorial 29 | end type TestGammaFac 30 | 31 | contains 32 | 33 | function new_TestGammaFac(params) result(test) 34 | type(GammaTestInt), intent(in) :: params 35 | type(TestGammaFac) :: test 36 | 37 | test%input_int = real(params%test_int,r8) 38 | 39 | ! A curious fact; because the factorial contains so many powers of 2, 20! 40 | ! is exactly representable in an 8 byte double even though it is bigger 41 | ! than 1/epsilon. 42 | test%test_factorial = real(factorial(params%test_int-1),r8) 43 | 44 | contains 45 | 46 | function factorial(n) 47 | integer, intent(in) :: n 48 | integer(i8) :: factorial 49 | integer(i8) :: i 50 | factorial = product([( i, i = 1, n )]) 51 | end function factorial 52 | 53 | end function new_TestGammaFac 54 | 55 | function getParameters() result(params) 56 | type(GammaTestInt), allocatable :: params(:) 57 | 58 | integer :: i 59 | 60 | params = [( GammaTestInt(i), i = 1, 21 )] 61 | 62 | end function getParameters 63 | 64 | function toString(this) result(string) 65 | class(GammaTestInt), intent(in) :: this 66 | character(:), allocatable :: string 67 | 68 | character(len=80) :: buffer 69 | 70 | write(buffer, *) "(n = ",this%test_int,")" 71 | 72 | string = trim(buffer) 73 | 74 | end function toString 75 | 76 | @Test 77 | subroutine gamma_is_factorial(this) 78 | class(TestGammaFac), intent(inout) :: this 79 | 80 | real(r8) :: tol 81 | 82 | tol = relative_error_tolerance * this%test_factorial 83 | 84 | @assertEqual(this%test_factorial, gamma(this%input_int), tolerance=tol) 85 | end subroutine gamma_is_factorial 86 | 87 | @Test 88 | subroutine igamma_is_factorial(this) 89 | class(TestGammaFac), intent(inout) :: this 90 | 91 | real(r8) :: tol 92 | 93 | tol = relative_error_tolerance * this%test_factorial 94 | 95 | @assertEqual(this%test_factorial, igamma(this%input_int,0._r8), tolerance=tol) 96 | end subroutine igamma_is_factorial 97 | 98 | end module test_gamma_factorial 99 | -------------------------------------------------------------------------------- /RandNum/include/dSFMT-params.h: -------------------------------------------------------------------------------- 1 | #ifndef DSFMT_PARAMS_H 2 | #define DSFMT_PARAMS_H 3 | 4 | #include "dSFMT.h" 5 | 6 | /*---------------------- 7 | the parameters of DSFMT 8 | following definitions are in dSFMT-paramsXXXX.h file. 9 | ----------------------*/ 10 | /** the pick up position of the array. 11 | #define DSFMT_POS1 122 12 | */ 13 | 14 | /** the parameter of shift left as four 32-bit registers. 15 | #define DSFMT_SL1 18 16 | */ 17 | 18 | /** the parameter of shift right as four 32-bit registers. 19 | #define DSFMT_SR1 12 20 | */ 21 | 22 | /** A bitmask, used in the recursion. These parameters are introduced 23 | * to break symmetry of SIMD. 24 | #define DSFMT_MSK1 (uint64_t)0xdfffffefULL 25 | #define DSFMT_MSK2 (uint64_t)0xddfecb7fULL 26 | */ 27 | 28 | /** These definitions are part of a 128-bit period certification vector. 29 | #define DSFMT_PCV1 UINT64_C(0x00000001) 30 | #define DSFMT_PCV2 UINT64_C(0x00000000) 31 | */ 32 | 33 | #define DSFMT_LOW_MASK UINT64_C(0x000FFFFFFFFFFFFF) 34 | #define DSFMT_HIGH_CONST UINT64_C(0x3FF0000000000000) 35 | #define DSFMT_SR 12 36 | 37 | /* for sse2 */ 38 | #if defined(HAVE_SSE2) 39 | #define SSE2_SHUFF 0x1b 40 | #elif defined(HAVE_ALTIVEC) 41 | #if defined(__APPLE__) /* For OSX */ 42 | #define ALTI_SR (vector unsigned char)(4) 43 | #define ALTI_SR_PERM \ 44 | (vector unsigned char)(15,0,1,2,3,4,5,6,15,8,9,10,11,12,13,14) 45 | #define ALTI_SR_MSK \ 46 | (vector unsigned int)(0x000fffffU,0xffffffffU,0x000fffffU,0xffffffffU) 47 | #define ALTI_PERM \ 48 | (vector unsigned char)(12,13,14,15,8,9,10,11,4,5,6,7,0,1,2,3) 49 | #else 50 | #define ALTI_SR {4} 51 | #define ALTI_SR_PERM {15,0,1,2,3,4,5,6,15,8,9,10,11,12,13,14} 52 | #define ALTI_SR_MSK {0x000fffffU,0xffffffffU,0x000fffffU,0xffffffffU} 53 | #define ALTI_PERM {12,13,14,15,8,9,10,11,4,5,6,7,0,1,2,3} 54 | #endif 55 | #endif 56 | 57 | #if DSFMT_MEXP == 521 58 | #include "dSFMT-params521.h" 59 | #elif DSFMT_MEXP == 1279 60 | #include "dSFMT-params1279.h" 61 | #elif DSFMT_MEXP == 2203 62 | #include "dSFMT-params2203.h" 63 | #elif DSFMT_MEXP == 4253 64 | #include "dSFMT-params4253.h" 65 | #elif DSFMT_MEXP == 11213 66 | #include "dSFMT-params11213.h" 67 | #elif DSFMT_MEXP == 19937 68 | #include "dSFMT-params19937.h" 69 | #elif DSFMT_MEXP == 44497 70 | #include "dSFMT-params44497.h" 71 | #elif DSFMT_MEXP == 86243 72 | #include "dSFMT-params86243.h" 73 | #elif DSFMT_MEXP == 132049 74 | #include "dSFMT-params132049.h" 75 | #elif DSFMT_MEXP == 216091 76 | #include "dSFMT-params216091.h" 77 | #else 78 | #ifdef __GNUC__ 79 | #error "DSFMT_MEXP is not valid." 80 | #undef DSFMT_MEXP 81 | #else 82 | #undef DSFMT_MEXP 83 | #endif 84 | 85 | #endif 86 | 87 | #endif /* DSFMT_PARAMS_H */ 88 | -------------------------------------------------------------------------------- /src/shr_nl_mod.F90: -------------------------------------------------------------------------------- 1 | module shr_nl_mod 2 | 3 | ! Utilities for namelist reading 4 | ! Adapted Fall 2012 from CAM's namelist_utils. 5 | 6 | implicit none 7 | private 8 | 9 | save 10 | 11 | public :: & 12 | shr_nl_find_group_name ! seek through a file to find a specified namelist 13 | 14 | contains 15 | 16 | ! This routine probably discards more error code information than it needs to. 17 | 18 | subroutine shr_nl_find_group_name(unit, group, status) 19 | 20 | use shr_string_mod, only: shr_string_toLower 21 | 22 | !--------------------------------------------------------------------------------------- 23 | ! Purpose: 24 | ! Search a file that contains namelist input for the specified namelist group name. 25 | ! Leave the file positioned so that the current record is the first record of the 26 | ! input for the specified group. 27 | ! 28 | ! Method: 29 | ! Read the file line by line. Each line is searched for an '&' which may only 30 | ! be preceded by blanks, immediately followed by the group name which is case 31 | ! insensitive. If found then backspace the file so the current record is the 32 | ! one containing the group name and return success. Otherwise return -1. 33 | ! 34 | ! Author: B. Eaton, August 2007 35 | !--------------------------------------------------------------------------------------- 36 | 37 | integer, intent(in) :: unit ! fortran unit attached to file 38 | character(len=*), intent(in) :: group ! namelist group name 39 | integer, intent(out) :: status ! 0 for success, -1 if group name not found 40 | 41 | ! Local variables 42 | 43 | integer :: len_grp 44 | integer :: ios ! io status 45 | character(len=80) :: inrec ! first 80 characters of input record 46 | character(len=80) :: inrec2 ! left adjusted input record 47 | character(len=len(group)) :: lc_group 48 | 49 | !--------------------------------------------------------------------------- 50 | 51 | len_grp = len_trim(group) 52 | lc_group = shr_string_toLower(group) 53 | 54 | ios = 0 55 | do while (ios <= 0) 56 | 57 | read(unit, '(a)', iostat=ios, end=100) inrec 58 | 59 | if (ios <= 0) then ! ios < 0 indicates an end of record condition 60 | 61 | ! look for group name in this record 62 | 63 | ! remove leading blanks 64 | inrec2 = adjustl(inrec) 65 | 66 | ! check for leading '&' 67 | if (inrec2(1:1) == '&') then 68 | 69 | ! check for case insensitive group name 70 | if (trim(lc_group) == shr_string_toLower(inrec2(2:len_grp+1))) then 71 | 72 | ! found group name. backspace to leave file position at this record 73 | backspace(unit) 74 | status = 0 75 | return 76 | 77 | end if 78 | end if 79 | end if 80 | 81 | end do 82 | 83 | 100 continue ! end of file processing 84 | status = -1 85 | 86 | end subroutine shr_nl_find_group_name 87 | 88 | end module shr_nl_mod 89 | -------------------------------------------------------------------------------- /test/unit/shr_vmath_test/test_vmath.F90: -------------------------------------------------------------------------------- 1 | program test_vmath 2 | 3 | ! 4 | ! This is a test for the shr_vmath_mod module. 5 | ! 6 | 7 | use shr_kind_mod, only: r8 => shr_kind_r8 8 | use shr_kind_mod, only: r4 => shr_kind_r4 9 | use shr_kind_mod, only: i8 => shr_kind_i8 10 | use shr_kind_mod, only: i4 => shr_kind_i4 11 | use shr_const_mod, only: pi => shr_const_pi 12 | use shr_vmath_mod 13 | 14 | implicit none 15 | integer, parameter :: vlen = 128 16 | real(r8) :: ivec(vlen), rvec(vlen), ovec(vlen), nvec(vlen) 17 | real(r8), parameter :: bigval = 1.0E300_r8 18 | real(r8), parameter :: smallval = 1.0E-300_r8 19 | real(r8), parameter :: tolerance = 1.0E-15_r8 20 | integer :: i 21 | call random_number(ivec) ! numbers between 0 and 1 22 | 23 | ivec = ivec * bigval ! numbers between 0 and 1e308 24 | 25 | call shr_vmath_sqrt(ivec, rvec, vlen) 26 | 27 | ovec = dsqrt(ivec) 28 | do i=1,vlen 29 | if(abs(rvec(i)-ovec(i)) > tolerance) then 30 | print *,__LINE__,i, ivec(i),rvec(i),ovec(i) 31 | endif 32 | enddo 33 | 34 | rvec = (rvec - ovec)/ovec 35 | 36 | call assert(all(abs(rvec) < tolerance),"shr_vmath_sqrt test failed") 37 | 38 | call shr_vmath_rsqrt(ivec, rvec, vlen) 39 | 40 | ovec = 1.0_r8/ovec 41 | 42 | do i=1,vlen 43 | if(abs((rvec(i)-ovec(i))/ovec(i)) > tolerance) then 44 | print *,__LINE__,i, ivec(i),rvec(i),ovec(i) 45 | endif 46 | enddo 47 | 48 | rvec = (rvec - ovec)/ovec 49 | 50 | call assert(all(abs(rvec) < tolerance),"shr_vmath_rsqrt test failed") 51 | 52 | call random_number(nvec) 53 | nvec = (nvec - 0.5_r8)*bigval 54 | 55 | call shr_vmath_div(ivec, nvec, rvec, vlen) 56 | 57 | ovec = ivec/nvec 58 | 59 | rvec = (rvec - ovec)/ovec 60 | 61 | call assert(all(abs(rvec) < tolerance),"shr_vmath_div test failed") 62 | 63 | call random_number(ivec) 64 | ivec = ivec*1400_r8 - 700_r8 65 | 66 | call shr_vmath_exp(ivec, rvec, vlen) 67 | 68 | ovec = exp(ivec) 69 | !print *,minval(abs(rvec)),maxval(rvec) 70 | 71 | rvec = (rvec - ovec)/ovec 72 | 73 | call assert(all(abs(rvec) < tolerance),"shr_vmath_exp test failed") 74 | 75 | ivec = ovec 76 | call shr_vmath_log(ivec, rvec, vlen) 77 | ovec = log(ivec) 78 | 79 | rvec = (rvec - ovec)/ovec 80 | 81 | call assert(all(abs(rvec) < tolerance),"shr_vmath_log test failed") 82 | 83 | call random_number(ivec) 84 | ivec = (ivec-0.5_r8)*2.0_r8*pi 85 | call shr_vmath_sin(ivec, rvec, vlen) 86 | ovec = sin(ivec) 87 | rvec = (rvec - ovec)/ovec 88 | 89 | call assert(all(abs(rvec) < tolerance),"shr_vmath_sin test failed") 90 | 91 | call shr_vmath_cos(ivec, rvec, vlen) 92 | ovec = cos(ivec) 93 | rvec = (rvec - ovec)/ovec 94 | 95 | call assert(all(abs(rvec) < tolerance),"shr_vmath_cos test failed") 96 | 97 | contains 98 | 99 | subroutine assert(val, msg) 100 | logical, intent(in) :: val 101 | character(len=*), intent(in) :: msg 102 | 103 | if (.not. val) then 104 | print *, msg 105 | stop 1 106 | end if 107 | 108 | end subroutine assert 109 | 110 | end program test_vmath 111 | -------------------------------------------------------------------------------- /test/unit/dynamic_vector/int_ptr_vector_tests.pf.in: -------------------------------------------------------------------------------- 1 | module int_ptr_vector_tests 2 | ! Module to test dynamic vector template on 3 | ! a derived type. 4 | 5 | use funit 6 | 7 | use shr_log_mod, only: OOBMsg => shr_log_OOBMsg 8 | 9 | use ptr_wrapper, only: & 10 | int_ptr 11 | 12 | use dynamic_vector_int_ptr, only: & 13 | int_ptr_vector 14 | 15 | #define TYPE_NAME int_ptr 16 | #define TYPE_DECL type(TYPE_NAME) 17 | #define VECTOR_NAME int_ptr_vector 18 | 19 | implicit none 20 | 21 | integer, target, save :: i1, i2, i3, i4, i5 22 | 23 | type(int_ptr), save :: test_array(3) 24 | 25 | type(int_ptr), save :: test_array_2(5) 26 | 27 | type(int_ptr), save :: new_val 28 | 29 | interface assertEqual 30 | module procedure assertEqual_int_ptr_0D_0D 31 | module procedure assertEqual_int_ptr_0D_1D 32 | module procedure assertEqual_int_ptr_1D_1D 33 | end interface 34 | 35 | contains 36 | 37 | ! This is necessary because pFUnit only knows about integers, not the 38 | ! pointer type that we've defined. 39 | subroutine assertEqual_int_ptr_0D_0D(expected, found, message, location) 40 | type(int_ptr), intent(in) :: expected 41 | type(int_ptr), intent(in) :: found 42 | character(len=*), optional, intent(in) :: message 43 | type (SourceLocation), optional, intent(in) :: location 44 | 45 | call assertTrue(expected == found, message, location) 46 | 47 | end subroutine assertEqual_int_ptr_0D_0D 48 | 49 | subroutine assertEqual_int_ptr_0D_1D(expected, found, message, location) 50 | type(int_ptr), intent(in) :: expected 51 | type(int_ptr), intent(in) :: found(:) 52 | character(len=*), optional, intent(in) :: message 53 | type (SourceLocation), optional, intent(in) :: location 54 | 55 | call assertAll(expected == found, message, location) 56 | 57 | end subroutine assertEqual_int_ptr_0D_1D 58 | 59 | subroutine assertEqual_int_ptr_1D_1D(expected, found, message, location) 60 | type(int_ptr), intent(in) :: expected(:) 61 | type(int_ptr), intent(in) :: found(:) 62 | character(len=*), optional, intent(in) :: message 63 | type (SourceLocation), optional, intent(in) :: location 64 | 65 | call assertAll(expected == found, message, location) 66 | 67 | end subroutine assertEqual_int_ptr_1D_1D 68 | 69 | @Before 70 | subroutine setUp() 71 | 72 | test_array(1)%p => i1 73 | test_array(2)%p => i2 74 | test_array(3)%p => i3 75 | 76 | test_array_2(1)%p => i5 77 | test_array_2(2)%p => i4 78 | nullify(test_array_2(3)%p) 79 | test_array_2(4)%p => i2 80 | test_array_2(5)%p => i1 81 | 82 | new_val%p => i4 83 | 84 | end subroutine setUp 85 | 86 | @After 87 | subroutine tearDown() 88 | 89 | integer :: i 90 | 91 | do i = 1, size(test_array) 92 | nullify(test_array(i)%p) 93 | end do 94 | 95 | do i = 1, size(test_array_2) 96 | nullify(test_array_2(i)%p) 97 | end do 98 | 99 | nullify(new_val%p) 100 | 101 | end subroutine tearDown 102 | 103 | #include "dynamic_vector_base_tests.inc" 104 | 105 | end module int_ptr_vector_tests 106 | -------------------------------------------------------------------------------- /test/unit/shr_assert_test/test_macro.pf: -------------------------------------------------------------------------------- 1 | module test_macro 2 | 3 | ! Test that if NDEBUG is not defined, shr_assert macros run assertions. 4 | 5 | use funit 6 | 7 | #undef NDEBUG 8 | #include "shr_assert.h" 9 | 10 | contains 11 | 12 | @Test 13 | subroutine macro_assert_can_pass() 14 | SHR_ASSERT(.true., "Assert macro unexpectedly aborted!") 15 | end subroutine macro_assert_can_pass 16 | 17 | @Test 18 | subroutine macro_assert_can_fail() 19 | SHR_ASSERT(.false., "Expected failure.") 20 | ! When this was written, the preprocessor did not recognize this assert, 21 | ! so call it directly instead of using an "@". 22 | call assertExceptionRaised("ABORTED: ERROR: Expected failure.") 23 | end subroutine macro_assert_can_fail 24 | 25 | @Test 26 | subroutine macro_assert_fl() 27 | SHR_ASSERT_FL(.false., "my_file", 42) 28 | call assertExceptionRaised("ABORTED: ERROR in my_file at line 42") 29 | end subroutine macro_assert_fl 30 | 31 | @Test 32 | subroutine macro_assert_mfl() 33 | SHR_ASSERT_MFL(.false., "Expected failure.", "my_file", 42) 34 | call assertExceptionRaised("ABORTED: ERROR in my_file at line 42: Expected failure.") 35 | end subroutine macro_assert_mfl 36 | 37 | @Test 38 | subroutine macro_assert_all_can_pass() 39 | SHR_ASSERT_ALL(([.true., .true.]), "Assert macro unexpectedly aborted!") 40 | end subroutine macro_assert_all_can_pass 41 | 42 | @Test 43 | subroutine macro_assert_all_can_fail() 44 | SHR_ASSERT_ALL(([.true., .false.]), "Expected failure.") 45 | ! When this was written, the preprocessor did not recognize this assert, 46 | ! so call it directly instead of using an "@". 47 | call assertExceptionRaised("ABORTED: ERROR: Expected failure.") 48 | end subroutine macro_assert_all_can_fail 49 | 50 | @Test 51 | subroutine macro_assert_all_fl() 52 | SHR_ASSERT_ALL_FL(([.true., .false.]), "my_file", 42) 53 | call assertExceptionRaised("ABORTED: ERROR in my_file at line 42") 54 | end subroutine macro_assert_all_fl 55 | 56 | @Test 57 | subroutine macro_assert_all_mfl() 58 | SHR_ASSERT_ALL_MFL(([.true., .false.]), "Expected failure.", "my_file", 42) 59 | call assertExceptionRaised("ABORTED: ERROR in my_file at line 42: Expected failure.") 60 | end subroutine macro_assert_all_mfl 61 | 62 | @Test 63 | subroutine macro_assert_any_can_pass() 64 | SHR_ASSERT_ANY(([.true., .false.]), "Assert macro unexpectedly aborted!") 65 | end subroutine macro_assert_any_can_pass 66 | 67 | @Test 68 | subroutine macro_assert_any_can_fail() 69 | SHR_ASSERT_ANY(([.false., .false.]), "Expected failure.") 70 | ! When this was written, the preprocessor did not recognize this assert, 71 | ! so call it directly instead of using an "@". 72 | call assertExceptionRaised("ABORTED: ERROR: Expected failure.") 73 | end subroutine macro_assert_any_can_fail 74 | 75 | @Test 76 | subroutine macro_assert_any_fl() 77 | SHR_ASSERT_ANY_FL(([.false., .false.]), "my_file", 42) 78 | call assertExceptionRaised("ABORTED: ERROR in my_file at line 42") 79 | end subroutine macro_assert_any_fl 80 | 81 | @Test 82 | subroutine macro_assert_any_mfl() 83 | SHR_ASSERT_ANY_MFL(([.false., .false.]), "Expected failure.", "my_file", 42) 84 | call assertExceptionRaised("ABORTED: ERROR in my_file at line 42: Expected failure.") 85 | end subroutine macro_assert_any_mfl 86 | 87 | end module test_macro 88 | -------------------------------------------------------------------------------- /RandNum/test/bench/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile created by mkmf $Id: mkmf,v 18.0.18.4 2012/12/04 15:24:15 Seth.Underwood Exp $ 2 | 3 | ifeq ($(COMPILER),intel) 4 | FC := ifort 5 | LD := ifort 6 | LDFLAGS += -mkl 7 | CC := icc 8 | 9 | # Sandy Bridge/Ivy Bridge 10 | 11 | FFLAGS := -O3 -xHost -fp-model fast -mkl -no-prec-div -no-prec-sqrt -override-limits 12 | 13 | CFLAGS := -O3 -xHost -fp-model fast -std=c99 14 | 15 | CPPDEFS = -DINTEL_MKL -DHAVE_SSE2 16 | 17 | 18 | # Knights Corner 19 | 20 | # FFLAGS := -mmic -O3 -qopt-report=5 -fp-model fast -no-prec-div -no-prec-sqrt -I./ 21 | 22 | # Haswell 23 | 24 | # FFLAGS := -O3 -xCORE-AVX2 -no-prec-div -no-prec-sqrt -I./ -DCPRINTEL 25 | 26 | endif 27 | 28 | ifeq ($(COMPILER),pgi) 29 | FC := pgfortran 30 | LD := pgfortran 31 | CC := pgcc 32 | 33 | FFLAGS := -fastsse 34 | CFLAGS := -fastsse 35 | CPPDEFS = 36 | endif 37 | 38 | ifeq ($(COMPILER),gnu) 39 | FC := gfortran 40 | LD := gfortran 41 | CC := gcc 42 | 43 | FFLAGS := -Ofast -march=native 44 | CFLAGS := -Ofast -march=native -std=gnu99 45 | CPPDEFS = -DHAVE_SSE2 46 | endif 47 | 48 | ifeq ($(COMPILER),nag) 49 | FC := nagfor 50 | LD := nagfor 51 | CC := gcc 52 | 53 | FFLAGS := -O4 54 | CFLAGS := -Ofast -march=native -std=gnu99 55 | CPPDEFS = -DHAVE_SSE2 56 | endif 57 | 58 | ifeq ($(COMPILER),ibm) 59 | FC := xlf2003 60 | LD := xlf2003 61 | CC := xlc 62 | 63 | FFLAGS := -O4 64 | CFLAGS := -O4 65 | CPPDEFS = 66 | endif 67 | 68 | CPPDEFS := $(CPPDEFS) -DDSFMT_MEXP=19937 69 | 70 | ifeq ($(COMPILER),ibm) 71 | cpre = $(null)-WF,-D$(null) 72 | FPPDEFS := $(patsubst -D%,$(cpre)%,$(CPPDEF)) 73 | else 74 | FPPDEFS := $(CPPDEFS) 75 | endif 76 | 77 | FFLAGS := $(FFLAGS) $(FPPDEFS) -I../../include -I./ 78 | CFLAGS := $(CFLAGS) $(CPPDEFS) -I../../include 79 | 80 | .DEFAULT: 81 | -echo $@ does not exist. 82 | all: ./shr_RandNum.exe 83 | dSFMT.o: ../../src/dsfmt_f03/dSFMT.c 84 | $(CC) $(CPPFLAGS) $(CFLAGS) $(OTHERFLAGS) -c ../../src/dsfmt_f03/dSFMT.c 85 | dSFMT_interface.o: ../../src/dsfmt_f03/dSFMT_interface.F90 86 | $(FC) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) -c ../../src/dsfmt_f03/dSFMT_interface.F90 87 | dSFMT_utils.o: ../../src/dsfmt_f03/dSFMT_utils.c ../../include/dSFMT.h 88 | $(CC) $(CPPFLAGS) $(CFLAGS) $(OTHERFLAGS) -c ../../src/dsfmt_f03/dSFMT_utils.c 89 | kissvec_mod.o: ../../src/kissvec/kissvec_mod.F90 90 | $(FC) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) -c ../../src/kissvec/kissvec_mod.F90 91 | kissvec.o: ../../src/kissvec/kissvec.c 92 | $(CC) $(CPPFLAGS) $(CFLAGS) $(OTHERFLAGS) -c ../../src/kissvec/kissvec.c 93 | test_shr_RandNum.o: ./test_shr_RandNum.F90 shr_RandNum_mod.o 94 | $(FC) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) -c ./test_shr_RandNum.F90 95 | mersennetwister_mod.o: ../../src/mt19937/mersennetwister_mod.F90 96 | $(FC) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) -c ../../src/mt19937/mersennetwister_mod.F90 97 | shr_RandNum_mod.o: ../../src/shr_RandNum_mod.F90 kissvec_mod.o mersennetwister_mod.o dSFMT_interface.o 98 | $(FC) $(CPPFLAGS) $(FPPFLAGS) $(FFLAGS) $(OTHERFLAGS) -c ../../src/shr_RandNum_mod.F90 99 | SRC = ./test_shr_RandNum.F90 ../kissvec/kissvec_mod.F90 ../mt19937/mersennetwister_mod.F90 ../dsfmt_f03/dSFMT.c ../dsfmt_f03/dSFMT_interface.F90 ../dsfmt_f03/dSFMT_utils.c ../shr_RandNum_mod.F90 ../../include/dSFMT.h 100 | OBJ = test_shr_RandNum.o kissvec_mod.o mersennetwister_mod.o dSFMT.o dSFMT_interface.o dSFMT_utils.o shr_RandNum_mod.o kissvec.o 101 | clean: 102 | -rm -f .shr_RandNum.exe.cppdefs $(OBJ) *.mod ./shr_RandNum.exe *.s 103 | shr_RandNum.exe: $(OBJ) 104 | $(LD) $(OBJ) -o shr_RandNum.exe $(LDFLAGS) 105 | -------------------------------------------------------------------------------- /test/unit/dynamic_vector/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | include_directories(.) 2 | 3 | # Because these tests use type parameterization, unfortunately we need to 4 | # preprocess *before* running the pFUnit preprocessor, then again *after*. 5 | if(${CMAKE_C_COMPILER_ID} STREQUAL GNU OR ${CMAKE_C_COMPILER_ID} STREQUAL Clang OR ${CMAKE_C_COMPILER_ID} STREQUAL AppleClang) 6 | function(make_cpp_command varname start_file end_file) 7 | set(${varname} ${CMAKE_C_COMPILER} -E -x c ${start_file} -o ${end_file} 8 | PARENT_SCOPE) 9 | endfunction() 10 | elseif(${CMAKE_C_COMPILER_ID} STREQUAL Intel OR ${CMAKE_C_COMPILER_ID} STREQUAL IntelLLVM) 11 | function(make_cpp_command varname start_file end_file) 12 | set(${varname} "${CMAKE_C_COMPILER} -E ${start_file} -o ${end_file}" 13 | PARENT_SCOPE) 14 | endfunction() 15 | elseif(${CMAKE_C_COMPILER_ID} STREQUAL XL) 16 | function(make_cpp_command varname start_file end_file) 17 | get_filename_component(start_base ${start_file} NAME) 18 | string(REGEX REPLACE "\\.[^.]+$" ".i" cpp_output ${start_base}) 19 | # Unfortunately, the C preprocessor doesn't like Fortran syntax, and 20 | # returns a non-zero error code even though it succeeds. Use "|| :" to 21 | # tell CMake that the command succeeded. 22 | set(${varname} ${CMAKE_C_COMPILER} -E ${start_file} > ${end_file} || : 23 | PARENT_SCOPE) 24 | endfunction() 25 | endif() 26 | 27 | # Function to preprocess the input to the output with the C preprocessor. 28 | # Any extra arguments are interpreted as header files that preprocessing 29 | # depends on. Unfortunately, we lose CMake's intrinsic capability to 30 | # track included files as dependencies. 31 | function(c_preprocess in_file out_file) 32 | if(IS_ABSOLUTE "${in_file}") 33 | set(start_file "${in_file}") 34 | else() 35 | set(start_file "${CMAKE_CURRENT_SOURCE_DIR}/${in_file}") 36 | endif() 37 | if(IS_ABSOLUTE "${out_file}") 38 | set(end_file "${out_file}") 39 | else() 40 | set(end_file "${CMAKE_CURRENT_BINARY_DIR}/${out_file}") 41 | endif() 42 | set(includes ${ARGN}) 43 | 44 | make_cpp_command(cpp_command ${start_file} ${end_file}) 45 | separate_arguments(cpp_command) 46 | add_custom_command( 47 | OUTPUT ${end_file} 48 | COMMAND ${cpp_command} 49 | DEPENDS ${start_file} ${includes} 50 | ) 51 | 52 | endfunction() 53 | 54 | # Included in tests we preprocess here. 55 | set(test_include 56 | ${CMAKE_CURRENT_SOURCE_DIR}/dynamic_vector_base_tests.inc) 57 | 58 | # Clear before loop below. 59 | unset(pf_sources) 60 | 61 | # File with int_ptr type. 62 | set(test_sources ptr_wrapper.F90) 63 | 64 | set(sources_needed shr_kind_mod.F90 shr_infnan_mod.F90 65 | shr_strconvert_mod.F90 shr_log_mod.F90) 66 | extract_sources("${sources_needed}" "${share_sources}" test_sources) 67 | 68 | # Loop over type tests. 69 | # 70 | # The idea is that integer tests an intrinsic type, real(r8) is a type with 71 | # a kind, character is special because of its length and substring syntax, 72 | # and int_ptr is a simple derived type. 73 | 74 | # "character16" could be in the following list, but right now it is broken 75 | # on multiple compilers due to compiler bugs. 76 | foreach(type IN ITEMS integer r8 int_ptr) 77 | c_preprocess(${type}_vector_tests.pf.in ${type}_vector_tests.pf 78 | ${test_include}) 79 | list(APPEND pf_sources 80 | ${CMAKE_CURRENT_BINARY_DIR}/${type}_vector_tests.pf) 81 | list(APPEND test_sources 82 | dynamic_vector_${type}.F90) 83 | endforeach() 84 | 85 | add_pfunit_ctest(dynamic_vector 86 | TEST_SOURCES "${pf_sources}" 87 | OTHER_SOURCES "${test_sources}") 88 | 89 | declare_generated_dependencies(dynamic_vector "${share_genf90_sources}") 90 | 91 | target_link_libraries(dynamic_vector esmf) 92 | # The following adds all dependencies of ESMF, including PIO, NetCDF, etc.: 93 | target_link_libraries(dynamic_vector ESMF::ESMF) 94 | -------------------------------------------------------------------------------- /RandNum/include/dSFMT-common.h: -------------------------------------------------------------------------------- 1 | #pragma once 2 | /** 3 | * @file dSFMT-common.h 4 | * 5 | * @brief SIMD oriented Fast Mersenne Twister(SFMT) pseudorandom 6 | * number generator with jump function. This file includes common functions 7 | * used in random number generation and jump. 8 | * 9 | * @author Mutsuo Saito (Hiroshima University) 10 | * @author Makoto Matsumoto (The University of Tokyo) 11 | * 12 | * Copyright (C) 2006, 2007 Mutsuo Saito, Makoto Matsumoto and Hiroshima 13 | * University. 14 | * Copyright (C) 2012 Mutsuo Saito, Makoto Matsumoto, Hiroshima 15 | * University and The University of Tokyo. 16 | * All rights reserved. 17 | * 18 | * The 3-clause BSD License is applied to this software, see 19 | * LICENSE.txt 20 | */ 21 | #ifndef DSFMT_COMMON_H 22 | #define DSFMT_COMMON_H 23 | 24 | #include "dSFMT.h" 25 | 26 | #if defined(HAVE_SSE2) 27 | # include 28 | union X128I_T { 29 | uint64_t u[2]; 30 | __m128i i128; 31 | }; 32 | union X128D_T { 33 | double d[2]; 34 | __m128d d128; 35 | }; 36 | /** mask data for sse2 */ 37 | static const union X128I_T sse2_param_mask = {{DSFMT_MSK1, DSFMT_MSK2}}; 38 | #endif 39 | 40 | #if defined(HAVE_ALTIVEC) 41 | inline static void do_recursion(w128_t *r, w128_t *a, w128_t * b, 42 | w128_t *lung) { 43 | const vector unsigned char sl1 = ALTI_SL1; 44 | const vector unsigned char sl1_perm = ALTI_SL1_PERM; 45 | const vector unsigned int sl1_msk = ALTI_SL1_MSK; 46 | const vector unsigned char sr1 = ALTI_SR; 47 | const vector unsigned char sr1_perm = ALTI_SR_PERM; 48 | const vector unsigned int sr1_msk = ALTI_SR_MSK; 49 | const vector unsigned char perm = ALTI_PERM; 50 | const vector unsigned int msk1 = ALTI_MSK; 51 | vector unsigned int w, x, y, z; 52 | 53 | z = a->s; 54 | w = lung->s; 55 | x = vec_perm(w, (vector unsigned int)perm, perm); 56 | y = vec_perm(z, sl1_perm, sl1_perm); 57 | y = vec_sll(y, sl1); 58 | y = vec_and(y, sl1_msk); 59 | w = vec_xor(x, b->s); 60 | w = vec_xor(w, y); 61 | x = vec_perm(w, (vector unsigned int)sr1_perm, sr1_perm); 62 | x = vec_srl(x, sr1); 63 | x = vec_and(x, sr1_msk); 64 | y = vec_and(w, msk1); 65 | z = vec_xor(z, y); 66 | r->s = vec_xor(z, x); 67 | lung->s = w; 68 | } 69 | #elif defined(HAVE_SSE2) 70 | /** 71 | * This function represents the recursion formula. 72 | * @param r output 128-bit 73 | * @param a a 128-bit part of the internal state array 74 | * @param b a 128-bit part of the internal state array 75 | * @param d a 128-bit part of the internal state array (I/O) 76 | */ 77 | inline static void do_recursion(w128_t *r, w128_t *a, w128_t *b, w128_t *u) { 78 | __m128i v, w, x, y, z; 79 | 80 | x = a->si; 81 | z = _mm_slli_epi64(x, DSFMT_SL1); 82 | y = _mm_shuffle_epi32(u->si, SSE2_SHUFF); 83 | z = _mm_xor_si128(z, b->si); 84 | y = _mm_xor_si128(y, z); 85 | 86 | v = _mm_srli_epi64(y, DSFMT_SR); 87 | w = _mm_and_si128(y, sse2_param_mask.i128); 88 | v = _mm_xor_si128(v, x); 89 | v = _mm_xor_si128(v, w); 90 | r->si = v; 91 | u->si = y; 92 | } 93 | #else 94 | /** 95 | * This function represents the recursion formula. 96 | * @param r output 128-bit 97 | * @param a a 128-bit part of the internal state array 98 | * @param b a 128-bit part of the internal state array 99 | * @param lung a 128-bit part of the internal state array (I/O) 100 | */ 101 | inline static void do_recursion(w128_t *r, w128_t *a, w128_t * b, 102 | w128_t *lung) { 103 | uint64_t t0, t1, L0, L1; 104 | 105 | t0 = a->u[0]; 106 | t1 = a->u[1]; 107 | L0 = lung->u[0]; 108 | L1 = lung->u[1]; 109 | lung->u[0] = (t0 << DSFMT_SL1) ^ (L1 >> 32) ^ (L1 << 32) ^ b->u[0]; 110 | lung->u[1] = (t1 << DSFMT_SL1) ^ (L0 >> 32) ^ (L0 << 32) ^ b->u[1]; 111 | r->u[0] = (lung->u[0] >> DSFMT_SR) ^ (lung->u[0] & DSFMT_MSK1) ^ t0; 112 | r->u[1] = (lung->u[1] >> DSFMT_SR) ^ (lung->u[1] & DSFMT_MSK2) ^ t1; 113 | } 114 | #endif 115 | #endif 116 | -------------------------------------------------------------------------------- /cmake/FindPIO.cmake: -------------------------------------------------------------------------------- 1 | # - Try to find PIO 2 | # 3 | # This can be controled by setting PIO_PATH or PIO__PATH Cmake variables, 4 | # where is the COMPONENT language one needs. 5 | # 6 | # Once done, this will define: 7 | # 8 | # PIO__FOUND (BOOL) - system has PIO 9 | # PIO__IS_SHARED (BOOL) - whether the library is shared/dynamic 10 | # PIO__INCLUDE_DIR (PATH) - Location of the header files and modules 11 | # PIO__LIBRARY (File) - Path to the library files 12 | # PIO__LIBRARIES (List) - link these to use PIO 13 | # 14 | # Available COMPONENTS are: C Fortran 15 | # If no components are specified only C is assumed 16 | include (LibFind) 17 | include (LibCheck) 18 | 19 | # Define PIO C Component 20 | define_package_component(PIO DEFAULT 21 | COMPONENT C 22 | INCLUDE_NAMES pio.h 23 | LIBRARY_NAMES pioc) 24 | 25 | # Define PIO Fortran Component 26 | define_package_component(PIO 27 | COMPONENT Fortran 28 | INCLUDE_NAMES pio.mod pio.inc 29 | LIBRARY_NAMES piof) 30 | 31 | # Search for list of valid components requested 32 | find_valid_components(PIO) 33 | 34 | #============================================================================== 35 | # SEARCH FOR VALIDATED COMPONENTS 36 | foreach (pcomp IN LISTS PIO_FIND_VALID_COMPONENTS) 37 | 38 | # If not found already, search... 39 | if (NOT PIO_${pcomp}_FOUND) 40 | 41 | # Manually add the MPI include and library dirs to search paths 42 | # and search for the package component 43 | if (MPI_${pcomp}_FOUND) 44 | initialize_paths (PIO_${pcomp}_PATHS 45 | INCLUDE_DIRECTORIES ${MPI_${pcomp}_INCLUDE_PATH} 46 | LIBRARIES ${MPI_${pcomp}_LIBRARIES}) 47 | find_package_component(PIO COMPONENT ${pcomp} 48 | PATHS ${PIO_${pcomp}_PATHS}) 49 | else () 50 | find_package_component(PIO COMPONENT ${pcomp} HINT PIO_${pcomp}_PATH=${PIO_PATH}) 51 | endif () 52 | 53 | # Continue only if component found 54 | if (PIO_${pcomp}_FOUND) 55 | 56 | # Checks 57 | if (pcomp STREQUAL C) 58 | 59 | # Check version 60 | check_version (PIO 61 | NAME "pio_meta.h" 62 | HINTS ${PIO_C_INCLUDE_DIRS} 63 | MACRO_REGEX "PIO_VERSION_") 64 | 65 | endif () 66 | 67 | # Dependencies 68 | if (pcomp STREQUAL C AND NOT PIO_C_IS_SHARED) 69 | 70 | # DEPENDENCY: PnetCDF (if PnetCDF enabled) 71 | check_macro (PIO_HAS_PNETCDF 72 | NAME TryPIO_PNETCDF.c 73 | HINTS ${CMAKE_MODULE_PATH} 74 | DEFINITIONS -I${PIO_C_INCLUDE_DIR} 75 | COMMENT "whether PIO has PnetCDF support") 76 | if (PIO_HAS_PNETCDF) 77 | find_package (PnetCDF COMPONENTS C) 78 | endif () 79 | 80 | 81 | elseif (pcomp STREQUAL Fortran AND NOT PIO_Fortran_IS_SHARED) 82 | 83 | # DEPENDENCY: PIO 84 | set (orig_comp ${pcomp}) 85 | set (orig_comps ${PIO_FIND_VALID_COMPONENTS}) 86 | find_package (PIO COMPONENTS C) 87 | set (PIO_FIND_VALID_COMPONENTS ${orig_comps}) 88 | set (pcomp ${orig_comp}) 89 | if (PIO_C_FOUND) 90 | list (APPEND PIO_Fortran_INCLUDE_DIRS ${PIO_C_INCLUDE_DIRS}) 91 | list (APPEND PIO_Fortran_LIBRARIES ${PIO_C_LIBRARIES}) 92 | endif () 93 | 94 | endif () 95 | 96 | endif () 97 | 98 | endif () 99 | 100 | endforeach () 101 | message("PIO_C_FOUND ${PIO_C_FOUND}") 102 | message("PIO_Fortran_FOUND ${PIO_Fortran_FOUND}") 103 | message("PIO_Fortran_INCLUDE_DIR ${PIO_Fortran_INCLUDE_DIR}") 104 | -------------------------------------------------------------------------------- /src/shr_mem_mod.F90: -------------------------------------------------------------------------------- 1 | MODULE shr_mem_mod 2 | 3 | use shr_kind_mod, only : shr_kind_r8 4 | use shr_log_mod, only: s_logunit => shr_log_Unit 5 | use shr_sys_mod, only: shr_sys_abort 6 | 7 | implicit none 8 | private 9 | 10 | ! PUBLIC: Public interfaces 11 | 12 | public :: shr_mem_getusage, & 13 | shr_mem_init 14 | 15 | ! PUBLIC: Public interfaces 16 | 17 | real(shr_kind_r8) :: mb_blk = 0.0_shr_kind_r8 18 | 19 | !=============================================================================== 20 | CONTAINS 21 | !=============================================================================== 22 | 23 | subroutine shr_mem_init(prt, strbuf) 24 | 25 | implicit none 26 | 27 | !----- arguments ----- 28 | 29 | logical, optional :: prt 30 | character(len=*), optional :: strbuf 31 | !----- local ----- 32 | 33 | ! --- Memory stats --- 34 | integer :: msize ! memory size (high water) 35 | integer :: mrss0,mrss1,mrss2 ! temporary rss 36 | integer :: mshare,mtext,mdatastack 37 | logical :: lprt 38 | integer :: ierr 39 | 40 | integer :: GPTLget_memusage 41 | 42 | real(shr_kind_r8),allocatable :: mem_tmp(:) 43 | 44 | character(*),parameter :: subname = "(shr_mem_init)" 45 | !--------------------------------------------------- 46 | 47 | lprt = .false. 48 | if (present(prt)) then 49 | lprt = prt 50 | endif 51 | 52 | ierr = GPTLget_memusage (msize, mrss0, mshare, mtext, mdatastack) 53 | if (ierr .ne. 0) call shr_sys_abort(trim(subname)//': GPTLget_memusage mrss0 failed') 54 | 55 | allocate(mem_tmp(1024*1024), stat=ierr) ! 1 MWord, 8 MB 56 | if (ierr .ne. 0) call shr_sys_abort(trim(subname)//': allocate failed') 57 | 58 | mem_tmp = -1.0 59 | ierr = GPTLget_memusage (msize, mrss1, mshare, mtext, mdatastack) 60 | if (ierr .ne. 0) call shr_sys_abort(trim(subname)//': GPTLget_memusage mrss1 failed') 61 | 62 | deallocate(mem_tmp, stat=ierr) 63 | if (ierr .ne. 0) call shr_sys_abort(trim(subname)//': deallocate failed') 64 | 65 | ierr = GPTLget_memusage (msize, mrss2, mshare, mtext, mdatastack) 66 | if (ierr .ne. 0) call shr_sys_abort(trim(subname)//': GPTLget_memusage mrss2 failed') 67 | 68 | mb_blk = 0.0_shr_kind_r8 69 | if (mrss1 - mrss0 > 0) then 70 | mb_blk = (8.0_shr_kind_r8)/((mrss1-mrss0)*1.0_shr_kind_r8) 71 | endif 72 | 73 | if (lprt) then 74 | write(s_logunit,'(A,f16.2)') '8 MB memory alloc in MB is ',(mrss1-mrss0)*mb_blk 75 | write(s_logunit,'(A,f16.2)') '8 MB memory dealloc in MB is ',(mrss1-mrss2)*mb_blk 76 | write(s_logunit,'(A,f16.2)') 'Memory block size conversion in bytes is ',mb_blk*1024.0_shr_kind_r8*1024.0_shr_kind_r8 77 | endif 78 | if (present(strbuf)) then 79 | write(strbuf,'(3(A,f16.2))') '8 MB memory alloc in MB is ',(mrss1-mrss0)*mb_blk, & 80 | '\n8 MB memory dealloc in MB is ',(mrss1-mrss2)*mb_blk, & 81 | '\nMemory block size conversion in bytes is ',mb_blk*1024.0_shr_kind_r8*1024.0_shr_kind_r8 82 | endif 83 | 84 | 85 | end subroutine shr_mem_init 86 | 87 | !=============================================================================== 88 | 89 | subroutine shr_mem_getusage(r_msize,r_mrss,prt) 90 | 91 | implicit none 92 | 93 | !----- arguments --- 94 | real(shr_kind_r8) :: r_msize,r_mrss 95 | logical, optional :: prt 96 | 97 | !----- local --- 98 | integer :: msize,mrss 99 | integer :: mshare,mtext,mdatastack 100 | integer :: ierr 101 | integer :: GPTLget_memusage, GPTLprint_memusage 102 | 103 | !--------------------------------------------------- 104 | 105 | ierr = GPTLget_memusage (msize, mrss, mshare, mtext, mdatastack) 106 | r_msize = msize / 1024.0_shr_kind_r8 107 | r_mrss = mrss / 1024.0_shr_kind_r8 108 | 109 | if (present(prt)) then 110 | if (prt) then 111 | ierr = GPTLprint_memusage(' ') 112 | endif 113 | endif 114 | 115 | 116 | end subroutine shr_mem_getusage 117 | 118 | !=============================================================================== 119 | 120 | END MODULE shr_mem_mod 121 | -------------------------------------------------------------------------------- /cmake/LibCheck.cmake: -------------------------------------------------------------------------------- 1 | include (CMakeParseArguments) 2 | include (CheckFunctionExists) 3 | #============================================================================== 4 | # 5 | # FUNCTIONS TO HELP WITH Check* MODULES 6 | # 7 | #============================================================================== 8 | 9 | #______________________________________________________________________________ 10 | # - Basic function to check a property of a package using a try_compile step 11 | # 12 | # SYNTAX: check_macro ( 13 | # NAME 14 | # HINTS ... 15 | # DEFINITIONS ... 16 | # COMMENT ) 17 | # 18 | function (check_macro VARIABLE) 19 | 20 | # Parse the input arguments 21 | set (oneValueArgs COMMENT NAME) 22 | set (multiValueArgs HINTS DEFINITIONS) 23 | cmake_parse_arguments (${VARIABLE} "" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) 24 | 25 | # If the return variable is defined, already, don't continue 26 | if (NOT DEFINED ${VARIABLE}) 27 | 28 | message (STATUS "Checking ${${VARIABLE}_COMMENT}") 29 | find_file (${VARIABLE}_TRY_FILE 30 | NAMES ${${VARIABLE}_NAME} 31 | HINTS ${${VARIABLE}_HINTS}) 32 | if (${VARIABLE}_TRY_FILE) 33 | try_compile (COMPILE_RESULT 34 | ${CMAKE_CURRENT_BINARY_DIR}/try${VARIABLE} 35 | SOURCES ${${VARIABLE}_TRY_FILE} 36 | COMPILE_DEFINITIONS ${${VARIABLE}_DEFINITIONS} 37 | OUTPUT_VARIABLE TryOUT) 38 | if (COMPILE_RESULT) 39 | message (STATUS "Checking ${${VARIABLE}_COMMENT} - yes") 40 | else () 41 | message (STATUS "Checking ${${VARIABLE}_COMMENT} - no") 42 | endif () 43 | 44 | set (${VARIABLE} ${COMPILE_RESULT} 45 | CACHE BOOL "${${VARIABLE}_COMMENT}") 46 | 47 | else () 48 | message (STATUS "Checking ${${VARIABLE}_COMMENT} - failed") 49 | endif () 50 | 51 | unset (${VARIABLE}_TRY_FILE CACHE) 52 | endif () 53 | 54 | endfunction () 55 | 56 | #______________________________________________________________________________ 57 | # - Basic function to check the version of a package using a try_run step 58 | # 59 | # SYNTAX: check_version ( 60 | # NAME 61 | # HINTS ... 62 | # DEFINITIONS ...) 63 | # 64 | function (check_version PKG) 65 | 66 | # Parse the input arguments 67 | set (oneValueArgs NAME MACRO_REGEX) 68 | set (multiValueArgs HINTS) 69 | cmake_parse_arguments (${PKG} "" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) 70 | 71 | # If the return variable is defined, already, don't continue 72 | if (NOT DEFINED ${PKG}_VERSION) 73 | 74 | message (STATUS "Checking ${PKG} version") 75 | find_file (${PKG}_VERSION_HEADER 76 | NAMES ${${PKG}_NAME} 77 | HINTS ${${PKG}_HINTS}) 78 | if (${PKG}_VERSION_HEADER) 79 | set (def) 80 | file (STRINGS ${${PKG}_VERSION_HEADER} deflines 81 | REGEX "^#define[ \\t]+${${PKG}_MACRO_REGEX}") 82 | foreach (defline IN LISTS deflines) 83 | string (REPLACE "\"" "" defline "${defline}") 84 | string (REPLACE "." "" defline "${defline}") 85 | string (REGEX REPLACE "[ \\t]+" ";" deflist "${defline}") 86 | list (GET deflist 2 arg) 87 | list (APPEND def ${arg}) 88 | endforeach () 89 | string (REPLACE ";" "." vers "${def}") 90 | message (STATUS "Checking ${PKG} version - ${vers}") 91 | set (${PKG}_VERSION ${vers} 92 | CACHE STRING "${PKG} version string") 93 | if (${PKG}_VERSION VERSION_LESS ${PKG}_FIND_VERSION}) 94 | message (FATAL_ERROR "${PKG} version insufficient") 95 | endif () 96 | else () 97 | message (STATUS "Checking ${PKG} version - failed") 98 | endif () 99 | 100 | unset (${PKG}_VERSION_HEADER CACHE) 101 | 102 | endif () 103 | 104 | endfunction () -------------------------------------------------------------------------------- /test/unit/shr_spfn_test/test_erf_r4.pf: -------------------------------------------------------------------------------- 1 | module test_erf_r4 2 | 3 | use funit 4 | 5 | use shr_kind_mod, only: & 6 | r4 => shr_kind_r4 7 | 8 | use shr_spfn_mod, only: & 9 | erf => shr_spfn_erf, & 10 | erfc => shr_spfn_erfc, & 11 | erfc_scaled => shr_spfn_erfc_scaled 12 | 13 | implicit none 14 | save 15 | 16 | ! Approximately what (negative) number makes erfc_scaled overflow? 17 | real(r4), parameter :: erfc_scaled_overflow = 9._r4 18 | 19 | @TestParameter 20 | type, extends(AbstractTestParameter) :: ErfR4Params 21 | real(r4) :: test_point 22 | real(r4) :: erf_val 23 | real(r4) :: tol = 0._r4 24 | contains 25 | procedure :: toString 26 | end type ErfR4Params 27 | 28 | @TestCase(testParameters={getParameters()}, constructor=new_TestErfR4) 29 | type, extends(ParameterizedTestCase) :: TestErfR4 30 | real(r4) :: test_point 31 | real(r4) :: erf_val 32 | real(r4) :: tol 33 | end type TestErfR4 34 | 35 | contains 36 | 37 | function new_TestErfR4(params) result(test) 38 | type(ErfR4Params), intent(in) :: params 39 | type(TestErfR4) :: test 40 | 41 | test%test_point = params%test_point 42 | test%erf_val = params%erf_val 43 | test%tol = params%tol 44 | 45 | end function new_TestErfR4 46 | 47 | function getParameters() result(params) 48 | type(ErfR4Params), allocatable :: params(:) 49 | 50 | params = [ & 51 | ErfR4Params(0._r4, 0._r4), & 52 | ErfR4Params(15._r4, 1._r4), & 53 | ErfR4Params(-15._r4, -1._r4), & 54 | ErfR4Params(1._r4, 0.842700792949714869341, tol=1.e-5_r4), & 55 | ErfR4Params(-1._r4, -0.842700792949714869341, tol=1.e-5_r4) ] 56 | 57 | end function getParameters 58 | 59 | function toString(this) result(string) 60 | class(ErfR4Params), intent(in) :: this 61 | character(:), allocatable :: string 62 | 63 | character(len=80) :: buffer 64 | 65 | write(buffer, '(A,F8.4,A,F8.4,A)') & 66 | "(point = ",this%test_point,", erf = ",this%erf_val,")" 67 | 68 | string = trim(buffer) 69 | 70 | end function toString 71 | 72 | ! Check that the erf function gets the expected result. 73 | @Test 74 | subroutine erf_r4_has_correct_value(this) 75 | class(TestErfR4), intent(inout) :: this 76 | @assertEqual(this%erf_val, erf(this%test_point), tolerance=this%tol) 77 | end subroutine erf_r4_has_correct_value 78 | 79 | ! Check that two runs of the erf function get identical results. 80 | @Test 81 | subroutine erf_r4_is_reproducible(this) 82 | class(TestErfR4), intent(inout) :: this 83 | @assertEqual(erf(this%test_point), erf(this%test_point)) 84 | end subroutine erf_r4_is_reproducible 85 | 86 | ! Check that erfc(x) = 1 - erf(x). 87 | @Test 88 | subroutine erfc_r4_has_correct_value(this) 89 | class(TestErfR4), intent(inout) :: this 90 | @assertEqual(1._r4 - this%erf_val, erfc(this%test_point), tolerance=this%tol) 91 | end subroutine erfc_r4_has_correct_value 92 | 93 | ! Check that two runs of the erfc function get identical results. 94 | @Test 95 | subroutine erfc_r4_is_reproducible(this) 96 | class(TestErfR4), intent(inout) :: this 97 | @assertEqual(erfc(this%test_point), erfc(this%test_point)) 98 | end subroutine erfc_r4_is_reproducible 99 | 100 | ! Check that erfc_scaled(x) = exp(x**2) * (1 - erf(x)). 101 | @Test 102 | subroutine erfc_scaled_r4_has_correct_value(this) 103 | class(TestErfR4), intent(inout) :: this 104 | real(r4) :: erfc_scaled_expected 105 | 106 | ! Distinguish between where the test point has a modest value, or is too 107 | ! big to use a naive calculation. 108 | if (abs(this%test_point) < erfc_scaled_overflow) then 109 | erfc_scaled_expected = exp(this%test_point**2)*(1._r4 - this%erf_val) 110 | else 111 | ! For larger positive values, we could use an approximation, but this 112 | ! is not trivial. Large negative values should overflow; the only 113 | ! thing we could possibly check in that case would be to ensure that 114 | ! the implementation throws a floating-point error. 115 | 116 | ! For now, just automatically pass the test for large values. 117 | return 118 | end if 119 | 120 | @assertEqual(erfc_scaled_expected, erfc_scaled(this%test_point), tolerance=this%tol) 121 | end subroutine erfc_scaled_r4_has_correct_value 122 | 123 | ! Check that two runs of the erfc_scaled function get identical results. 124 | @Test 125 | subroutine erfc_scaled_r4_is_reproducible(this) 126 | class(TestErfR4), intent(inout) :: this 127 | ! Skip this if we overflow. 128 | if (this%test_point < -erfc_scaled_overflow) return 129 | @assertEqual(erfc_scaled(this%test_point), erfc_scaled(this%test_point)) 130 | end subroutine erfc_scaled_r4_is_reproducible 131 | 132 | end module test_erf_r4 133 | -------------------------------------------------------------------------------- /test/unit/shr_spfn_test/test_erf_r8.pf: -------------------------------------------------------------------------------- 1 | module test_erf_r8 2 | 3 | use funit 4 | 5 | use shr_kind_mod, only: & 6 | r8 => shr_kind_r8 7 | 8 | use shr_spfn_mod, only: & 9 | erf => shr_spfn_erf, & 10 | erfc => shr_spfn_erfc, & 11 | erfc_scaled => shr_spfn_erfc_scaled 12 | 13 | implicit none 14 | save 15 | 16 | ! Approximately what (negative) number makes erfc_scaled overflow? 17 | real(r8), parameter :: erfc_scaled_overflow = 26._r8 18 | 19 | @TestParameter 20 | type, extends(AbstractTestParameter) :: ErfR8Params 21 | real(r8) :: test_point 22 | real(r8) :: erf_val 23 | real(r8) :: tol = 0._r8 24 | contains 25 | procedure :: toString 26 | end type ErfR8Params 27 | 28 | @TestCase(testParameters={getParameters()}, constructor=new_TestErfR8) 29 | type, extends(ParameterizedTestCase) :: TestErfR8 30 | real(r8) :: test_point 31 | real(r8) :: erf_val 32 | real(r8) :: tol 33 | end type TestErfR8 34 | 35 | contains 36 | 37 | function new_TestErfR8(params) result(test) 38 | type(ErfR8Params), intent(in) :: params 39 | type(TestErfR8) :: test 40 | 41 | test%test_point = params%test_point 42 | test%erf_val = params%erf_val 43 | test%tol = params%tol 44 | 45 | end function new_TestErfR8 46 | 47 | function getParameters() result(params) 48 | type(ErfR8Params), allocatable :: params(:) 49 | 50 | params = [ & 51 | ErfR8Params(0._r8, 0._r8), & 52 | ErfR8Params(30._r8, 1._r8), & 53 | ErfR8Params(-30._r8, -1._r8), & 54 | ErfR8Params(1._r8, 0.842700792949714869341, tol=1.e-6_r8), & 55 | ErfR8Params(-1._r8, -0.842700792949714869341, tol=1.e-6_r8) ] 56 | 57 | end function getParameters 58 | 59 | function toString(this) result(string) 60 | class(ErfR8Params), intent(in) :: this 61 | character(:), allocatable :: string 62 | 63 | character(len=80) :: buffer 64 | 65 | write(buffer, '(A,F8.4,A,F8.4,A)') & 66 | "(point = ",this%test_point,", erf = ",this%erf_val,")" 67 | 68 | string = trim(buffer) 69 | 70 | end function toString 71 | 72 | ! Check that the erf function gets the expected result. 73 | @Test 74 | subroutine erf_r8_has_correct_value(this) 75 | class(TestErfR8), intent(inout) :: this 76 | @assertEqual(this%erf_val, erf(this%test_point), tolerance=this%tol) 77 | end subroutine erf_r8_has_correct_value 78 | 79 | ! Check that two runs of the erf function get identical results. 80 | @Test 81 | subroutine erf_r8_is_reproducible(this) 82 | class(TestErfR8), intent(inout) :: this 83 | @assertEqual(erf(this%test_point), erf(this%test_point)) 84 | end subroutine erf_r8_is_reproducible 85 | 86 | ! Check that erfc(x) = 1 - erf(x). 87 | @Test 88 | subroutine erfc_r8_has_correct_value(this) 89 | class(TestErfR8), intent(inout) :: this 90 | @assertEqual(1._r8 - this%erf_val, erfc(this%test_point), tolerance=this%tol) 91 | end subroutine erfc_r8_has_correct_value 92 | 93 | ! Check that two runs of the erfc function get identical results. 94 | @Test 95 | subroutine erfc_r8_is_reproducible(this) 96 | class(TestErfR8), intent(inout) :: this 97 | @assertEqual(erfc(this%test_point), erfc(this%test_point)) 98 | end subroutine erfc_r8_is_reproducible 99 | 100 | ! Check that erfc_scaled(x) = exp(x**2) * (1 - erf(x)). 101 | @Test 102 | subroutine erfc_scaled_r8_has_correct_value(this) 103 | class(TestErfR8), intent(inout) :: this 104 | real(r8) :: erfc_scaled_expected 105 | 106 | ! Distinguish between where the test point has a modest value, or is too 107 | ! big to use a naive calculation. 108 | if (abs(this%test_point) < erfc_scaled_overflow) then 109 | erfc_scaled_expected = exp(this%test_point**2)*(1._r8 - this%erf_val) 110 | else 111 | ! For larger positive values, we could use an approximation, but this 112 | ! is not trivial. Large negative values should overflow; the only 113 | ! thing we could possibly check in that case would be to ensure that 114 | ! the implementation throws a floating-point error. 115 | 116 | ! For now, just automatically pass the test for large values. 117 | return 118 | end if 119 | 120 | @assertEqual(erfc_scaled_expected, erfc_scaled(this%test_point), tolerance=this%tol) 121 | end subroutine erfc_scaled_r8_has_correct_value 122 | 123 | ! Check that two runs of the erfc_scaled function get identical results. 124 | @Test 125 | subroutine erfc_scaled_r8_is_reproducible(this) 126 | class(TestErfR8), intent(inout) :: this 127 | ! Skip this if we overflow. 128 | if (this%test_point < -erfc_scaled_overflow) return 129 | @assertEqual(erfc_scaled(this%test_point), erfc_scaled(this%test_point)) 130 | end subroutine erfc_scaled_r8_is_reproducible 131 | 132 | end module test_erf_r8 133 | -------------------------------------------------------------------------------- /src/shr_abort_mod.F90: -------------------------------------------------------------------------------- 1 | module shr_abort_mod 2 | ! This module defines procedures that can be used to abort the model cleanly in a 3 | ! system-specific manner 4 | ! 5 | ! The public routines here are only meant to be used directly by shr_sys_mod. Other code 6 | ! that wishes to use these routines should use the republished names from shr_sys_mod 7 | ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from 8 | ! when these routines were defined in shr_sys_mod.) 9 | 10 | use shr_kind_mod, only : shr_kind_in, shr_kind_cx 11 | 12 | #ifdef CPRNAG 13 | ! NAG does not provide this as an intrinsic, but it does provide modules 14 | ! that implement commonly used POSIX routines. 15 | use f90_unix_proc, only: abort 16 | #endif 17 | 18 | implicit none 19 | 20 | ! PUBLIC: Public interfaces 21 | 22 | private 23 | 24 | ! The public routines here are only meant to be used directly by shr_sys_mod. Other code 25 | ! that wishes to use these routines should use the republished names from shr_sys_mod 26 | ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from 27 | ! when these routines were defined in shr_sys_mod.) 28 | public :: shr_abort_abort ! abort a program 29 | public :: shr_abort_backtrace ! print a backtrace, if possible 30 | 31 | contains 32 | 33 | !=============================================================================== 34 | subroutine shr_abort_abort(string,rc, line, file) 35 | use esmf, only : ESMF_LOGWRITE, ESMF_LOGMSG_ERROR, ESMF_FINALIZE, ESMF_END_ABORT 36 | use shr_log_mod, only : shr_log_error 37 | ! Consistent stopping mechanism 38 | 39 | !----- arguments ----- 40 | character(len=*) , intent(in), optional :: string ! error message string 41 | integer(shr_kind_in), intent(in), optional :: rc ! error code 42 | integer(shr_kind_in), intent(in), optional :: line 43 | character(len=*), intent(in), optional :: file 44 | 45 | ! Local version of the string. 46 | ! (Gets a default value if string is not present.) 47 | character(len=shr_kind_cx) :: local_string 48 | integer :: lrc 49 | !------------------------------------------------------------------------------- 50 | 51 | if (present(string)) then 52 | local_string = trim(string) 53 | else 54 | local_string = "Unknown error submitted to shr_abort_abort." 55 | end if 56 | if(present(rc)) then 57 | write(local_string, *) trim(local_string), ' rc=',rc 58 | lrc = rc 59 | else 60 | lrc = 0 61 | endif 62 | 63 | call shr_log_error(local_string, rc=lrc, line=line, file=file) 64 | 65 | call shr_abort_backtrace() 66 | 67 | call ESMF_Finalize(endflag=ESMF_END_ABORT) 68 | 69 | ! A compiler's abort method may print a backtrace or do other nice 70 | ! things, but in fact we can rarely leverage this, because MPI_Abort 71 | ! usually sends SIGTERM to the process, and we don't catch that signal. 72 | call abort() 73 | 74 | end subroutine shr_abort_abort 75 | !=============================================================================== 76 | 77 | !=============================================================================== 78 | subroutine shr_abort_backtrace() 79 | ! This routine uses compiler-specific facilities to print a backtrace to 80 | ! error_unit (standard error, usually unit 0). 81 | 82 | #if defined(CPRIBM) 83 | 84 | ! This theoretically should be in xlfutility, but using it from that 85 | ! module doesn't seem to always work. 86 | interface 87 | subroutine xl_trbk() 88 | end subroutine xl_trbk 89 | end interface 90 | 91 | call xl__trbk() 92 | 93 | #elif defined(CPRGNU) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8 )) 94 | 95 | ! gfortran 4.8 and later implement this intrinsic. We explicitly call it 96 | ! out as such to make sure that it really is available, just in case the 97 | ! CPP logic above screws up. 98 | intrinsic :: backtrace 99 | 100 | call backtrace() 101 | 102 | #elif defined(CPRINTEL) 103 | 104 | ! tracebackqq uses optional arguments, so *must* have an explicit 105 | ! interface. 106 | use ifcore, only: tracebackqq 107 | 108 | ! An exit code of -1 is a special value that prevents this subroutine 109 | ! from aborting the run. 110 | call tracebackqq(user_exit_code=-1) 111 | 112 | #else 113 | 114 | ! Currently we have no means to request a backtrace from the NAG runtime, 115 | ! even though it is capable of emitting backtraces itself, if you use the 116 | ! "-gline" option. 117 | 118 | ! Similarly, PGI has a -traceback option, but no user interface for 119 | ! requesting a backtrace to be printed. 120 | 121 | #endif 122 | 123 | end subroutine shr_abort_backtrace 124 | !=============================================================================== 125 | 126 | end module shr_abort_mod 127 | -------------------------------------------------------------------------------- /src/shr_frz_mod.F90.in: -------------------------------------------------------------------------------- 1 | module shr_frz_mod 2 | 3 | !=============================================================================== 4 | ! This is a module used for the freezing point of salt water 5 | !=============================================================================== 6 | 7 | use shr_kind_mod, only: R8=>SHR_KIND_R8, CS=>SHR_KIND_CS 8 | use shr_log_mod, only: s_logunit => shr_log_Unit, shr_log_level 9 | use shr_sys_mod, only: shr_sys_abort 10 | 11 | implicit none 12 | 13 | !---------------------------------------------------------------------------- 14 | ! PUBLIC: Interfaces and global data 15 | !---------------------------------------------------------------------------- 16 | public :: shr_frz_freezetemp, shr_frz_freezetemp_init 17 | 18 | interface shr_frz_freezetemp 19 | module procedure shr_frz_freezetemp_0d 20 | module procedure shr_frz_freezetemp_1d 21 | module procedure shr_frz_freezetemp_2d 22 | end interface shr_frz_freezetemp 23 | 24 | integer, public, parameter :: TFREEZE_OPTION_MINUS1P8 = 1 25 | integer, public, parameter :: TFREEZE_OPTION_LINEAR_SALT = 2 26 | integer, public, parameter :: TFREEZE_OPTION_MUSHY = 3 27 | integer, public, parameter :: TFREEZE_OPTION_UNINITIALIZED = -999 28 | 29 | private 30 | 31 | integer :: tfrz_option = TFREEZE_OPTION_UNINITIALIZED 32 | 33 | !=============================================================================== 34 | contains 35 | !=============================================================================== 36 | 37 | subroutine shr_frz_freezetemp_init(tfreeze_option, mastertask) 38 | 39 | implicit none 40 | 41 | character(len=*),parameter :: subname = "(shr_frz_freezetemp_init) " 42 | character(CS),intent(in) :: tfreeze_option ! option for computing freezing point 43 | logical, intent(in) :: mastertask ! for io 44 | ! minus1p8 is constant -1.8C 45 | ! linear_salt is linear equation 46 | ! mushy for CICE mushy-layer nonlinear equation 47 | 48 | !--------------------------------------------------------------- 49 | ! Check tfreeze_option 50 | !--------------------------------------------------------------- 51 | if (trim(tfreeze_option) == 'minus1p8') then 52 | if (mastertask .and. shr_log_level>0) write(s_logunit,*) ' tfreeze_option is minus1p8' 53 | tfrz_option = TFREEZE_OPTION_MINUS1P8 54 | elseif (trim(tfreeze_option) == 'linear_salt') then 55 | if (mastertask .and. shr_log_level>0) write(s_logunit,*) ' tfreeze_option is linear_salt' 56 | tfrz_option = TFREEZE_OPTION_LINEAR_SALT 57 | elseif (trim(tfreeze_option) == 'mushy') then 58 | if (mastertask .and. shr_log_level>0) write(s_logunit,*) ' tfreeze_option is mushy' 59 | tfrz_option = TFREEZE_OPTION_MUSHY 60 | else 61 | call shr_sys_abort(subname//' ERROR: not a valid tfreeze_option '//trim(tfreeze_option)) 62 | endif 63 | 64 | end subroutine shr_frz_freezetemp_init 65 | 66 | ! DIMS 0,1,2 67 | function shr_frz_freezetemp_{DIMS}d(s) result(shr_frz_freezetemp) 68 | 69 | !---------------------------------------------------------------------------- 70 | ! 71 | ! FUNCTION to return the freezing point of salt water in degrees Celsus 72 | ! 73 | !--------------- Code History ----------------------------------------------- 74 | ! 75 | ! Original Author: David Bailey 76 | ! Date: Feb, 2016 77 | !---------------------------------------------------------------------------- 78 | 79 | implicit none 80 | 81 | character(len=*),parameter :: subname = "(shr_frz_freezetemp_{DIMS}d) " 82 | 83 | real (R8),intent(in) :: s{DIMSTR} ! Salinity in psu 84 | #if ({DIMS}==0) 85 | real (R8) :: shr_frz_freezetemp 86 | #elif ({DIMS}==1) 87 | real (R8) :: shr_frz_freezetemp(size(s)) 88 | #elif ({DIMS}==2) 89 | real (R8) :: shr_frz_freezetemp(size(s,1),size(s,2)) 90 | #endif 91 | 92 | !---------------------------------------------------------------------------- 93 | shr_frz_freezetemp = -274.0_R8 94 | if (tfrz_option == TFREEZE_OPTION_MINUS1P8) then 95 | shr_frz_freezetemp = -1.8_R8 96 | elseif (tfrz_option == TFREEZE_OPTION_LINEAR_SALT) then 97 | shr_frz_freezetemp = -0.0544_R8*max(s,0.0_R8) 98 | elseif (tfrz_option == TFREEZE_OPTION_MUSHY) then 99 | ! This form is the high temperature part of the liquidus relation (Assur 1958) 100 | shr_frz_freezetemp = max(s,0.0_R8) & 101 | / (-18.48_R8 + (0.01848_R8*max(s,0.0_R8))) 102 | else 103 | call shr_sys_abort(subname//' ERROR: not intialized correctly with a valid tfreeze_option - & 104 | &call shr_frz_freezetemp_init first with a valid tfreeze_option') 105 | endif 106 | 107 | shr_frz_freezetemp = max(shr_frz_freezetemp,-2.0_R8) 108 | 109 | end function shr_frz_freezetemp_{DIMS}d 110 | 111 | !=============================================================================== 112 | 113 | end module shr_frz_mod 114 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CESM_share 2 | 3 | ## Description of CESM_share 4 | 5 | This module exists to collect code shared between various CESM components. 6 | Excluding this "shared code" module, CESM components are built using disjoint 7 | sets of source code. The use of this shared code is similar to the use of 8 | object code libraries where each subdirectory of share is equivalant to 9 | one library. While object library routines are accessed by linking to libraries 10 | during the load phase, these shared code routines are accessed by including the 11 | appropriate source code directory path during the compile phase. 12 | 13 | Motivation for this code sharing includes: 14 | 15 | - facilitating consistent physics between all models. For example, uniform 16 | solar-zenith-angle/orbital calculations and uniform physical constants. 17 | - providing an interface/API between component models and the flux-coupler 18 | component in the CESM framework. 19 | - avoiding the need for redundant implementations of commonly needed 20 | functionality. For example netCDF file reading, basic mapping (re-gridding) 21 | functionality, and common character string manipulations. 22 | 23 | Current subsets ("libraries") of shared code only include: 24 | 25 | util - very generic, general-purpose code that is likely to be useful to all 26 | CESM components. CESM components may be explicitly required to use some 27 | parts of this code, for example the physical constants module. 28 | 29 | ## Building and running CESM_share unit tests 30 | 31 | ### Prerequisites 32 | 33 | The unit test build requires [CIME](https://github.com/esmci/cime) for the sake of various 34 | CMake modules. In addition, the easiest way to build and run the unit tests is to use 35 | CIME's run_tests.py script, which leverages machine configuration information from 36 | [ccs_config](https://github.com/esmci/ccs_config_cesm) or something similar. 37 | 38 | If you are testing this share code in the context of a CESM (or CAM, CTSM, etc.) checkout, 39 | then you already have the required cime and ccs_config_cesm repositories. If not, you will 40 | need to obtain recent versions of cime and ccs_config_cesm. (cime and ccs_config_cesm must be checked out in the same directory as each other - i.e., sibling directories of each other. The following instructions assume that they are also sibling directories of the share code; this isn't necessary, but if they are in a different location then you will need to adjust the path to cime's run_tests.py script in the below command.) 41 | 42 | If this share code is at the path `/PATH/TO/CODE/share`, then do the following: 43 | 44 | ``` 45 | cd /PATH/TO/CODE 46 | git clone https://github.com/ESMCI/cime.git 47 | git clone https://github.com/ESMCI/ccs_config_cesm.git ccs_config 48 | cd share 49 | ``` 50 | 51 | ### General procedure to build and run the unit tests 52 | 53 | You can build and run the unit tests with the following command; note that this reuses the 54 | existing `unit_tests.temp` directory (if present) in order to do an incremental rebuild of 55 | the unit tests from the last time you ran them from this directory: 56 | 57 | ``` 58 | ../cime/scripts/fortran_unit_testing/run_tests.py --build-dir ./unit_tests.temp --cmake-args " -DUNITTESTS=ON -DUSE_CIME_MACROS=ON" 59 | ``` 60 | 61 | Note that `UNITTESTS` and `USE_CIME_MACROS` are variables defined in the CESM_share CMake 62 | build to turn on specific behavior that is needed with this unit test build procedure (but 63 | would not be needed when using this CMake build to do a general-purpose build of the 64 | library). 65 | 66 | ### Specific procedure on derecho 67 | 68 | Some machines will require extra steps, e.g., so that various paths are set correctly. The exact steps needed depend on how the machine is configured and what variables are set for this machine in its CIME/ccs_config-based configuration. 69 | 70 | The following additional steps are needed on derecho. 71 | 72 | The starting point for these steps is this default module environment: 73 | 74 | ``` 75 | Currently Loaded Modules: 76 | 1) ncarenv/24.12 (S) 2) craype/2.7.31 3) intel/2024.2.1 4) ncarcompilers/1.0.0 5) libfabric/1.15.2.0 6) cray-mpich/8.1.29 7) hdf5/1.12.3 8) netcdf/4.9.2 77 | ``` 78 | 79 | First, swap / load some needed modules: 80 | 81 | ``` 82 | module swap cray-mpich mpi-serial 83 | module load parallelio 84 | ``` 85 | 86 | leading to this module environment: 87 | 88 | ``` 89 | Currently Loaded Modules: 90 | 1) ncarenv/24.12 (S) 2) craype/2.7.31 3) intel/2024.2.1 4) ncarcompilers/1.0.0 5) hdf5/1.12.3 6) netcdf/4.9.2 7) mpi-serial/2.5.0 8) parallelio/2.6.6 91 | ``` 92 | 93 | Next, set the `MPISERIAL` environment variable to help CMake find the location of the mpi-serial library: 94 | 95 | ``` 96 | export MPISERIAL=$NCAR_ROOT_MPI_SERIAL 97 | ``` 98 | 99 | (Note that the mpi-serial module sets `NCAR_ROOT_MPI_SERIAL`, but not the more general `MPISERIAL` environment variable.) 100 | 101 | Finally, run the [general command given above](#general-procedure-to-build-and-run-the-unit-tests) to build and run the unit tests. 102 | -------------------------------------------------------------------------------- /CMakeLists.txt: -------------------------------------------------------------------------------- 1 | cmake_minimum_required(VERSION 3.10) 2 | 3 | set(CIME_CMAKE_MODULE_DIRECTORY "" CACHE PATH "Path to CIME's CMake modules") 4 | if (NOT DEFINED CIME_CMAKE_MODULE_DIRECTORY OR CIME_CMAKE_MODULE_DIRECTORY STREQUAL "") 5 | message(FATAL_ERROR "You must set CIME_CMAKE_MODULE_DIRECTORY when invoking cmake, e.g. -DCIME_CMAKE_MODULE_DIRECTORY=/path/to/cime/CIME/non_py/src/CMake") 6 | endif() 7 | 8 | option(USE_CIME_MACROS "include a CIME-generated Macros.cmake file from CMAKE_BINARY_DIR" OFF) 9 | option(UNITTESTS "build the pfunit based tests (must have PFUNIT_ROOT)" OFF) 10 | option(WERROR "add the -Werror flag to compiler (works with gnu)" OFF) 11 | 12 | if (USE_CIME_MACROS) 13 | set(CIME_SKIP_MACROS OFF) 14 | else() 15 | set(CIME_SKIP_MACROS ON) 16 | endif() 17 | if (UNITTESTS) 18 | set(CIME_SKIP_UNITTESTS OFF) 19 | else() 20 | set(CIME_SKIP_UNITTESTS ON) 21 | endif() 22 | 23 | list(APPEND CMAKE_MODULE_PATH ${CMAKE_SOURCE_DIR}/cmake) 24 | list(APPEND CMAKE_MODULE_PATH ${CIME_CMAKE_MODULE_DIRECTORY}) 25 | 26 | include(CIME_initial_setup) 27 | 28 | project(SHARE LANGUAGES Fortran C VERSION 0.1) 29 | 30 | # CIME_utils defines an ENABLE_GENF90 option, which is OFF by default. However, we need 31 | # GENF90 in order to generate some of the files from *.in files in this library, so here 32 | # we set the default to ON. 33 | set(ENABLE_GENF90 ON CACHE BOOL "Use genf90.pl to regenerate out-of-date Fortran files from .in files.") 34 | include(CIME_utils) 35 | 36 | string (TOUPPER "${CMAKE_Fortran_COMPILER_ID}" CMAKE_Fortran_COMPILER_NAME) 37 | if (CMAKE_Fortran_COMPILER_NAME STREQUAL "XL") 38 | set (CMAKE_Fortran_COMPILER_NAME "IBM") 39 | endif () 40 | if (CMAKE_Fortran_COMPILER_NAME STREQUAL "INTELLLVM") 41 | set (CMAKE_Fortran_COMPILER_NAME "INTEL") 42 | endif () 43 | set (CMAKE_Fortran_COMPILER_DIRECTIVE "-DCPR${CMAKE_Fortran_COMPILER_NAME}" 44 | CACHE STRING "Fortran compiler name preprocessor directive") 45 | message("CMAKE_Fortran_COMPILER_DIRECTIVE is ${CMAKE_Fortran_COMPILER_DIRECTIVE}") 46 | set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${CMAKE_Fortran_COMPILER_DIRECTIVE} -I${CMAKE_SOURCE_DIR}/include -I${CMAKE_BINARY_DIR}") 47 | 48 | if (DEFINED ENV{PIO_ROOT}) 49 | message("PIO_ROOT is $ENV{PIO_ROOT}") 50 | link_directories("$ENV{PIO_ROOT}/lib") 51 | else() 52 | if (DEFINED PIO) 53 | set(PIO_PATH ${PIO}) 54 | else() 55 | set(PIO_PATH $ENV{PIO}) 56 | endif() 57 | find_package(PIO REQUIRED COMPONENT C Fortran PATH ${PIO_PATH}) 58 | link_directories(${PIO_LIBDIR}) 59 | endif() 60 | 61 | if (DEFINED MPILIB) 62 | if (${MPILIB} STREQUAL "mpi-serial") 63 | find_package(MPISERIAL COMPONENTS C Fortran REQUIRED) 64 | # We need this for the sake of includes of mpif.h 65 | include_directories(${MPISERIAL_Fortran_INCLUDE_DIR}) 66 | else() 67 | find_package(MPI REQUIRED) 68 | endif() 69 | else() 70 | find_package(MPI REQUIRED) 71 | endif() 72 | 73 | if (DEFINED ENV{ESMF_ROOT}) 74 | list(APPEND CMAKE_MODULE_PATH $ENV{ESMF_ROOT}/cmake) 75 | endif() 76 | 77 | find_package(ESMF REQUIRED) 78 | set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${ESMF_F90COMPILEPATHS} ") 79 | link_libraries("-L${ESMF_LIBSDIR}") 80 | 81 | if("${COMPILER}" STREQUAL "nag") 82 | set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -D__NAG__") 83 | endif() 84 | if(WERROR) 85 | set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Werror --warn-no-unused-dummy-argument --warn-no-missing-include-dirs -ffree-line-length-none") 86 | 87 | set_source_files_properties(src/shr_mpi_mod.F90 src/shr_reprosum_mod.F90 PROPERTIES COMPILE_OPTIONS "-Wno-error;-fallow-argument-mismatch") 88 | # This flag seems to be needed for temp variables generated by the compiler version in jammy 89 | set_source_files_properties(src/shr_assert_mod.F90 PROPERTIES COMPILE_OPTIONS "-Wno-error=maybe-uninitialized") 90 | set(CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -Werror -Wno-error=cpp") 91 | set_source_files_properties(src/shr_cal_mod.F90 PROPERTIES COMPILE_OPTIONS "-Wno-error=conversion") 92 | 93 | endif() 94 | 95 | # Among other things, this handles the genf90 generation 96 | add_subdirectory(src) 97 | 98 | file(GLOB FSOURCES "src/*.F90" "src/water_isotopes/*.F90" "RandNum/src/*.F90" "RandNum/src/*/*.F90") 99 | file(GLOB CSOURCES "src/*.c" "RandNum/src/*/*.c") 100 | 101 | add_library(csm_share STATIC ${CSOURCES} ${FSOURCES} ${share_genf90_sources} ) 102 | declare_generated_dependencies(csm_share "${share_genf90_sources}") 103 | 104 | # Add these include directories to all targets, including unit tests: 105 | include_directories(include RandNum/include) 106 | # But just add this to csm_share (adding this to all targets causes a failure in the 107 | # shr_cal tests for some reason, and is probably unnecessary): 108 | target_include_directories(csm_share PRIVATE ${CMAKE_BINARY_DIR}) 109 | 110 | if(UNITTESTS) 111 | # need to turn the warning check off for pfunit 112 | set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -Wno-error ${CMAKE_Fortran_COMPILER_DIRECTIVE} -I${CMAKE_BINARY_DIR}/unittests/shr_assert_test/mod/assert/ ") 113 | add_subdirectory(${CMAKE_SOURCE_DIR}/unit_test_stubs/util csm_share_stubs) 114 | add_subdirectory(${CMAKE_SOURCE_DIR}/test/unit ${CMAKE_BINARY_DIR}/unittests) 115 | endif() 116 | -------------------------------------------------------------------------------- /src/shr_log_mod.F90: -------------------------------------------------------------------------------- 1 | !BOP =========================================================================== 2 | ! 3 | ! !MODULE: shr_log_mod -- variables and methods for logging 4 | ! 5 | ! !DESCRIPTION: 6 | ! Low-level shared variables for logging. 7 | ! 8 | ! Also, routines for generating log file messages. 9 | ! 10 | ! !INTERFACE: ------------------------------------------------------------------ 11 | 12 | module shr_log_mod 13 | 14 | ! !USES: 15 | 16 | use shr_kind_mod, only: shr_kind_in, shr_kind_cx 17 | use shr_strconvert_mod, only: toString 18 | 19 | use, intrinsic :: iso_fortran_env, only: output_unit, error_unit 20 | 21 | implicit none 22 | private 23 | 24 | ! !PUBLIC TYPES: 25 | 26 | ! no public types 27 | 28 | ! !PUBLIC MEMBER FUNCTIONS: 29 | 30 | public :: shr_log_errMsg 31 | public :: shr_log_OOBMsg 32 | public :: shr_log_setLogUnit 33 | public :: shr_log_getLogUnit 34 | public :: shr_log_error 35 | 36 | ! !PUBLIC DATA MEMBERS: 37 | 38 | public :: shr_log_Level 39 | public :: shr_log_Unit 40 | 41 | !EOP 42 | 43 | ! low-level shared variables for logging, these may not be parameters 44 | integer(SHR_KIND_IN) :: shr_log_Level = 0 45 | integer(SHR_KIND_IN) :: shr_log_Unit = output_unit 46 | 47 | contains 48 | 49 | !=============================================================================== 50 | !BOP =========================================================================== 51 | ! 52 | ! !IROUTINE: shr_log_errMsg -- Return an error message containing file & line info 53 | ! 54 | ! !DESCRIPTION: 55 | ! Return an error message containing file & line info 56 | ! \newline 57 | ! errMsg = shr\_log\_errMsg(__FILE__, __LINE__) 58 | ! 59 | ! This is meant to be used when a routine expects a string argument for some message, 60 | ! but you want to provide file and line information. 61 | ! 62 | ! However: Note that the performance of this function can be very bad. It is currently 63 | ! maintained because it is used by old code, but you should probably avoid using this 64 | ! in new code if possible. 65 | ! 66 | ! !REVISION HISTORY: 67 | ! 2013-July-23 - Bill Sacks 68 | ! 69 | ! !INTERFACE: ------------------------------------------------------------------ 70 | 71 | pure function shr_log_errMsg(file, line) 72 | 73 | ! !INPUT/OUTPUT PARAMETERS: 74 | 75 | character(len=SHR_KIND_CX) :: shr_log_errMsg 76 | character(len=*), intent(in) :: file 77 | integer , intent(in) :: line 78 | 79 | !EOP 80 | 81 | shr_log_errMsg = 'ERROR in '//trim(file)//' at line '//toString(line) 82 | 83 | end function shr_log_errMsg 84 | 85 | ! Create a message for an out of bounds error. 86 | pure function shr_log_OOBMsg(operation, bounds, idx) result(OOBMsg) 87 | 88 | ! A name for the operation being attempted when the bounds error 89 | ! occurred. A string containing the subroutine name is ideal, but more 90 | ! generic descriptions such as "read", "modify", or "insert" could be used. 91 | character(len=*), intent(in) :: operation 92 | 93 | ! Upper and lower bounds allowed for the operation. 94 | integer, intent(in) :: bounds(2) 95 | 96 | ! Index at which access was attempted. 97 | integer, intent(in) :: idx 98 | 99 | ! Output message 100 | character(len=:), allocatable :: OOBMsg 101 | 102 | allocate(OOBMsg, source=(operation//": "//toString(idx)//" not in range ["//& 103 | toString(bounds(1))//", "//toString(bounds(2))//"].")) 104 | 105 | end function shr_log_OOBMsg 106 | 107 | subroutine shr_log_setLogUnit(unit) 108 | integer, intent(in) :: unit 109 | 110 | shr_log_unit = unit 111 | 112 | end subroutine shr_log_setLogUnit 113 | 114 | subroutine shr_log_getLogUnit(unit) 115 | integer, intent(out) :: unit 116 | 117 | unit = shr_log_unit 118 | 119 | end subroutine shr_log_getLogUnit 120 | 121 | subroutine shr_log_error(string, rc, line, file) 122 | use esmf, only : ESMF_LOGWRITE, ESMF_LOGMSG_ERROR, ESMF_FINALIZE, ESMF_END_ABORT, ESMF_FAILURE, ESMF_SUCCESS 123 | ! This routine prints error messages to shr_log_unit (which is standard output 124 | ! for most tasks in CESM), to the ESMF PET files and to standard error if shr_log_unit is a 125 | ! file. Sets rc to ESMF_FAILURE on return. 126 | 127 | !----- arguments ----- 128 | character(len=*) , intent(in) :: string ! error message string 129 | integer(shr_kind_in), intent(inout), optional :: rc ! error code 130 | integer(shr_kind_in), intent(in), optional :: line 131 | character(len=*), intent(in), optional :: file 132 | 133 | ! Local version of the string. 134 | ! (Gets a default value if string is not present.) 135 | character(len=shr_kind_cx) :: local_string 136 | integer, allocatable :: log_units(:) 137 | integer :: i 138 | !------------------------------------------------------------------------------- 139 | 140 | local_string = trim(string) 141 | if(present(rc)) then 142 | if (rc /= ESMF_SUCCESS) then 143 | write(local_string, *) trim(local_string), ' rc=',rc 144 | endif 145 | rc = ESMF_FAILURE 146 | endif 147 | 148 | call ESMF_LogWrite(local_string, ESMF_LOGMSG_ERROR, line=line, file=file) 149 | if (shr_log_unit == output_unit .or. shr_log_unit == error_unit) then 150 | ! If the log unit number is standard output or standard error, just 151 | ! print to that. 152 | allocate(log_units(1), source=[shr_log_unit]) 153 | else 154 | ! Otherwise print the same message to both the log unit and standard 155 | ! error. 156 | allocate(log_units(2), source=[error_unit, shr_log_unit]) 157 | end if 158 | 159 | do i = 1, size(log_units) 160 | write(log_units(i),*) trim(local_string) 161 | flush(log_units(i)) 162 | end do 163 | 164 | end subroutine shr_log_error 165 | 166 | end module shr_log_mod 167 | -------------------------------------------------------------------------------- /test/unit/shr_strconvert_test/test_toString.pf: -------------------------------------------------------------------------------- 1 | module test_toString 2 | 3 | ! Simple tests for printing intrinsic types. 4 | ! 5 | ! This module is somewhat repetitive, but it seems manageable enough that it's 6 | ! not worth invoking complex methods such as genf90, cpp hacks, or parameterized 7 | ! pFUnit tests to handle the different types. 8 | 9 | use funit 10 | 11 | use shr_kind_mod, only: & 12 | i4 => shr_kind_i4, & 13 | i8 => shr_kind_i8, & 14 | r4 => shr_kind_r4, & 15 | r8 => shr_kind_r8 16 | 17 | use shr_infnan_mod, only: & 18 | posinf => shr_infnan_posinf, & 19 | neginf => shr_infnan_neginf, & 20 | qnan => shr_infnan_qnan, & 21 | snan => shr_infnan_snan, & 22 | to_r4 => shr_infnan_to_r4, & 23 | to_r8 => shr_infnan_to_r8 24 | 25 | use shr_strconvert_mod, only: toString 26 | 27 | implicit none 28 | 29 | contains 30 | 31 | @Test 32 | subroutine toString_prints_i4() 33 | @assertEqual("1", toString(1_i4)) 34 | end subroutine toString_prints_i4 35 | 36 | @Test 37 | subroutine toString_prints_i4_longest_value() 38 | @assertEqual("-2147483648", toString(-huge(1_i4)-1_i4)) 39 | end subroutine toString_prints_i4_longest_value 40 | 41 | @Test 42 | subroutine toString_prints_i4_with_format() 43 | @assertEqual("00001", toString(1_i4, format_string="(I0.5)")) 44 | end subroutine toString_prints_i4_with_format 45 | 46 | @Test 47 | subroutine toString_prints_i8() 48 | @assertEqual("1", toString(1_i8)) 49 | end subroutine toString_prints_i8 50 | 51 | @Test 52 | subroutine toString_prints_i8_longest_value() 53 | @assertEqual("-9223372036854775808", toString(-huge(1_i8)-1_i8)) 54 | end subroutine toString_prints_i8_longest_value 55 | 56 | @Test 57 | subroutine toString_prints_i8_with_format() 58 | @assertEqual("00001", toString(1_i8, format_string="(I0.5)")) 59 | end subroutine toString_prints_i8_with_format 60 | 61 | @Test 62 | subroutine toString_prints_positive_r4() 63 | @assertEqual("+1.00000000E+00", toString(1._r4)) 64 | end subroutine toString_prints_positive_r4 65 | 66 | @Test 67 | subroutine toString_prints_negative_r4() 68 | @assertEqual("-1.00000000E+00", toString(-1._r4)) 69 | end subroutine toString_prints_negative_r4 70 | 71 | @Test 72 | subroutine toString_prints_positive_infinity_r4() 73 | character(len=:), allocatable :: string 74 | string = toString(to_r4(posinf)) 75 | @assertEqual("+Inf", string(1:4)) 76 | end subroutine toString_prints_positive_infinity_r4 77 | 78 | @Test 79 | subroutine toString_prints_negative_infinity_r4() 80 | character(len=:), allocatable :: string 81 | string = toString(to_r4(neginf)) 82 | @assertEqual("-Inf", string(1:4)) 83 | end subroutine toString_prints_negative_infinity_r4 84 | 85 | @Test 86 | subroutine toString_prints_qnan_r4() 87 | character(len=:), allocatable :: string 88 | string = toString(to_r4(qnan)) 89 | @assertLessThan(0, len(string), message="String is empty!") 90 | @assertEqual("NaN", string(1:3)) 91 | end subroutine toString_prints_qnan_r4 92 | 93 | @Test 94 | subroutine toString_prints_snan_r4() 95 | character(len=:), allocatable :: string 96 | string = toString(to_r4(snan)) 97 | @assertLessThan(0, len(string), message="String is empty!") 98 | @assertEqual("NaN", string(1:3)) 99 | end subroutine toString_prints_snan_r4 100 | 101 | @Test 102 | subroutine toString_prints_r4_with_format() 103 | ! Compiler-specific printing conventions, like the optional leading "+", or 104 | ! putting a "0" before a leading decimal point, are not standardized if 105 | ! format_string is specified. Therefore, pick a value that's not subject to 106 | ! these compiler-defined behaviors. 107 | @assertEqual("-1.50", toString(-1.5_r4, format_string="(F5.2)")) 108 | end subroutine toString_prints_r4_with_format 109 | 110 | @Test 111 | subroutine toString_prints_positive_r8() 112 | @assertEqual("+1.0000000000000000E+000", toString(1._r8)) 113 | end subroutine toString_prints_positive_r8 114 | 115 | @Test 116 | subroutine toString_prints_negative_r8() 117 | @assertEqual("-1.0000000000000000E+000", toString(-1._r8)) 118 | end subroutine toString_prints_negative_r8 119 | 120 | @Test 121 | subroutine toString_prints_positive_infinity_r8() 122 | character(len=:), allocatable :: string 123 | string = toString(to_r8(posinf)) 124 | @assertEqual("+Inf", string(1:4)) 125 | end subroutine toString_prints_positive_infinity_r8 126 | 127 | @Test 128 | subroutine toString_prints_negative_infinity_r8() 129 | character(len=:), allocatable :: string 130 | string = toString(to_r8(neginf)) 131 | @assertEqual("-Inf", string(1:4)) 132 | end subroutine toString_prints_negative_infinity_r8 133 | 134 | @Test 135 | subroutine toString_prints_qnan_r8() 136 | character(len=:), allocatable :: string 137 | string = toString(to_r8(qnan)) 138 | @assertLessThan(0, len(string), message="String is empty!") 139 | @assertEqual("NaN", string(1:3)) 140 | end subroutine toString_prints_qnan_r8 141 | 142 | @Test 143 | subroutine toString_prints_snan_r8() 144 | character(len=:), allocatable :: string 145 | string = toString(to_r8(snan)) 146 | @assertLessThan(0, len(string), message="String is empty!") 147 | @assertEqual("NaN", string(1:3)) 148 | end subroutine toString_prints_snan_r8 149 | 150 | @Test 151 | subroutine toString_prints_r8_with_format() 152 | ! Compiler-specific printing conventions, like the optional leading "+", or 153 | ! putting a "0" before a leading decimal point, are not standardized if 154 | ! format_string is specified. Therefore, pick a value that's not subject to 155 | ! these compiler-defined behaviors. 156 | @assertEqual("-1.50", toString(-1.5_r8, format_string="(F5.2)")) 157 | end subroutine toString_prints_r8_with_format 158 | 159 | @Test 160 | subroutine toString_prints_logical() 161 | @assertEqual("T", toString(.true.)) 162 | @assertEqual("F", toString(.false.)) 163 | end subroutine toString_prints_logical 164 | 165 | end module test_toString 166 | -------------------------------------------------------------------------------- /src/shr_strconvert_mod.F90: -------------------------------------------------------------------------------- 1 | module shr_strconvert_mod 2 | 3 | ! This module defines toString, a generic function for creating character type 4 | ! representations of data, as implemented for the most commonly used intrinsic 5 | ! types: 6 | ! 7 | ! - 4 and 8 byte integer 8 | ! - 4 and 8 byte real 9 | ! - logical 10 | ! 11 | ! No toString implementation is provided for character input, but this may be 12 | ! added if some use case arises. 13 | ! 14 | ! Currently, only scalar inputs are supported. The return type of this function 15 | ! is character with deferred (allocatable) length. 16 | ! 17 | ! The functions for integers and reals allow an optional format_string argument, 18 | ! which can be used to control the padding and precision of output as with any 19 | ! write statement. However, the implementations internally must use a 20 | ! preallocated buffer, so a format_string that significantly increases the size 21 | ! of the output may cause a run-time error or undefined behavior in the program. 22 | ! 23 | ! Other modules may want to provide extensions of toString for their own derived 24 | ! types. In this case there are two guidelines to observe: 25 | ! 26 | ! - It is preferable to have only one mandatory argument, which is the object to 27 | ! produce a string from. There may be other formatting options, but the 28 | ! implementation should do something sensible without these. 29 | ! 30 | ! - Since the main purpose of toString is to provide a human-readable 31 | ! representation of a type, especially for documentation or debugging 32 | ! purposes, refrain from printing large array components in their entirety 33 | ! (instead consider printing only the shape, or statistics such as 34 | ! min/mean/max for arrays of numbers). 35 | 36 | use shr_kind_mod, only: & 37 | i4 => shr_kind_i4, & 38 | i8 => shr_kind_i8, & 39 | r4 => shr_kind_r4, & 40 | r8 => shr_kind_r8, & 41 | cs => shr_kind_cs 42 | 43 | use shr_infnan_mod, only: & 44 | isnan => shr_infnan_isnan 45 | 46 | implicit none 47 | private 48 | 49 | ! Human-readable representation of data. 50 | public :: toString 51 | 52 | interface toString 53 | module procedure i4ToString 54 | module procedure i8ToString 55 | module procedure r4ToString 56 | module procedure r8ToString 57 | module procedure logicalToString 58 | end interface toString 59 | 60 | contains 61 | 62 | pure function i4ToString(input, format_string) result(string) 63 | integer(i4), intent(in) :: input 64 | character(len=*), intent(in), optional :: format_string 65 | character(len=:), allocatable :: string 66 | 67 | character(len=cs) :: buffer 68 | 69 | if (present(format_string)) then 70 | write(buffer, format_string) input 71 | else 72 | ! For most compilers, these two statements are equivalent to a format of 73 | ! '(I0)', but that's not technically in the standard. 74 | write(buffer, '(I11)') input 75 | buffer = adjustl(buffer) 76 | end if 77 | 78 | allocate(string, source=trim(buffer)) 79 | 80 | end function i4ToString 81 | 82 | pure function i8ToString(input, format_string) result(string) 83 | integer(i8), intent(in) :: input 84 | character(len=*), intent(in), optional :: format_string 85 | character(len=:), allocatable :: string 86 | 87 | character(len=cs) :: buffer 88 | 89 | if (present(format_string)) then 90 | write(buffer, format_string) input 91 | else 92 | ! For most compilers, these two statements are equivalent to a format of 93 | ! '(I0)', but that's not technically in the standard. 94 | write(buffer, '(I20)') input 95 | buffer = adjustl(buffer) 96 | end if 97 | 98 | allocate(string, source=trim(buffer)) 99 | 100 | end function i8ToString 101 | 102 | pure function r4ToString(input, format_string) result(string) 103 | real(r4), intent(in) :: input 104 | character(len=*), intent(in), optional :: format_string 105 | character(len=:), allocatable :: string 106 | 107 | character(len=cs) :: buffer 108 | 109 | if (present(format_string)) then 110 | write(buffer, format_string) input 111 | else 112 | write(buffer, '(ES15.8 E2)') input 113 | buffer = adjustl(buffer) 114 | ! Deal with the fact that the "+" sign is optional by simply adding it if 115 | ! it is not present, so that the default format is standardized across 116 | ! compilers. 117 | ! Assumes that compilers do not treat the sign bit on NaN values specially. 118 | if (.not. isnan(input) .and. all(buffer(1:1) /= ["-", "+"])) then 119 | buffer = "+" // trim(buffer) 120 | end if 121 | end if 122 | 123 | allocate(string, source=trim(buffer)) 124 | 125 | end function r4ToString 126 | 127 | pure function r8ToString(input, format_string) result(string) 128 | real(r8), intent(in) :: input 129 | character(len=*), intent(in), optional :: format_string 130 | character(len=:), allocatable :: string 131 | 132 | character(len=cs) :: buffer 133 | 134 | if (present(format_string)) then 135 | write(buffer, format_string) input 136 | else 137 | write(buffer, '(ES24.16 E3)') input 138 | buffer = adjustl(buffer) 139 | ! Deal with the fact that the "+" sign is optional by simply adding it if 140 | ! it is not present, so that the default format is standardized across 141 | ! compilers. 142 | ! Assumes that compilers do not treat the sign bit on NaN values specially. 143 | if (.not. isnan(input) .and. all(buffer(1:1) /= ["-", "+"])) then 144 | buffer = "+" // trim(buffer) 145 | end if 146 | end if 147 | 148 | allocate(string, source=trim(buffer)) 149 | 150 | end function r8ToString 151 | 152 | pure function logicalToString(input) result(string) 153 | logical, intent(in) :: input 154 | character(len=:), allocatable :: string 155 | 156 | ! We could use a write statement, but this is easier. 157 | allocate(character(len=1) :: string) 158 | if (input) then 159 | string = "T" 160 | else 161 | string = "F" 162 | end if 163 | 164 | end function logicalToString 165 | 166 | end module shr_strconvert_mod 167 | -------------------------------------------------------------------------------- /RandNum/test/bench/test_shr_RandNum.F90: -------------------------------------------------------------------------------- 1 | program test 2 | 3 | ! this program calls the available versions of the random generators 4 | 5 | use shr_RandNum_mod, only: ShrIntrinsicRandGen, ShrKissRandGen, & 6 | ShrF95MtRandGen, ShrDsfmtRandGen 7 | #ifdef INTEL_MKL 8 | use shr_RandNum_mod, only: ShrMklMtRandGen 9 | #endif 10 | 11 | INTEGER, parameter :: r8 = selected_real_kind(12) 12 | 13 | #ifdef INTEL_MKL 14 | type(ShrMklMtRandGen) :: mkl_gen 15 | #endif 16 | type(ShrKissRandGen) :: kiss_gen 17 | type(ShrF95MtRandGen) :: f95_mt_gen 18 | type(ShrIntrinsicRandGen) :: intrinsic_gen 19 | type(ShrDsfmtRandGen) :: dsfmt_gen 20 | 21 | integer, parameter :: nstream = 16 ! number of streams of random numbers 22 | integer, parameter :: length = 1000 ! length of stream of random numbers 23 | integer :: ntrials = 50000 24 | 25 | integer, dimension(nstream) :: seed = 7776578 26 | integer, dimension(nstream,4) :: kiss_seed 27 | integer, dimension(:,:), allocatable :: intrinsic_seed 28 | 29 | real(r8), dimension(nstream,length) :: array 30 | 31 | integer :: i, n, m, intrinsic_size 32 | integer :: c1, c2, cr, cm 33 | real(r8) :: dt, dt1,dt2 34 | 35 | #ifdef INTEL_MKL 36 | ! intel math kernel library mersenne twister 37 | 38 | call system_clock(c1, cr, cm) 39 | do m = 1,ntrials 40 | mkl_gen = ShrMklMtRandGen(seed) 41 | call mkl_gen%finalize() 42 | enddo 43 | call system_clock(c2, cr, cm); dt1 = dble(c2-c1)/dble(cr) 44 | 45 | mkl_gen = ShrMklMtRandGen(seed) 46 | call system_clock(c1, cr, cm) 47 | do m = 1,ntrials 48 | call mkl_gen%random(array) 49 | enddo 50 | call mkl_gen%finalize() 51 | call system_clock(c2, cr, cm); dt2 = dble(c2-c1)/dble(cr) 52 | dt = dt1+dt2 53 | print *, 'Init/term time (SFMT_MKL): ',dt1 54 | print *, 'Gen time (SFMT_MKL): ',dt2 55 | print *, 'Total time (SFMT_MKL): ',dt 56 | print *, 'MegaRNumbers (SFMT_MKL): ', 1.0e-6*dble(nstream*length*ntrials)/dt 57 | print *, 'Summation of Random Numbers: ', SUM(array) 58 | print *, '--------'; print *, '' 59 | #endif 60 | 61 | ! keep it simple stupid random number 62 | 63 | do n = 1,nstream 64 | do i = 1, 4 65 | kiss_seed(n,i) = seed(n)*i+n 66 | end do 67 | end do 68 | 69 | call system_clock(c1, cr, cm) 70 | do m = 1,ntrials 71 | kiss_gen = ShrKissRandGen(kiss_seed) 72 | call kiss_gen%finalize() 73 | enddo 74 | call system_clock(c2, cr, cm); dt1 = dble(c2-c1)/dble(cr) 75 | 76 | kiss_gen = ShrKissRandGen(kiss_seed) 77 | call system_clock(c1, cr, cm) 78 | do m = 1,ntrials 79 | call kiss_gen%random(array) 80 | enddo 81 | call kiss_gen%finalize() 82 | call system_clock(c2, cr, cm); dt2 = dble(c2-c1)/dble(cr) 83 | dt = dt1+dt2 84 | print *, 'Init/term time (KISSVEC): ',dt1 85 | print *, 'Gen time (KISSVEC): ',dt2 86 | print *, 'Total time (KISSVEC): ',dt 87 | print *, 'MegaRNumbers (KISSVEC): ', 1.0e-6*dble(nstream*length*ntrials)/dt 88 | print *, 'Summation of Random Numbers: ', SUM(array) 89 | print *, '--------'; print *, '' 90 | 91 | ! fortran-95 implementation of merseene twister 92 | 93 | call system_clock(c1, cr, cm) 94 | do m = 1,ntrials 95 | f95_mt_gen = ShrF95MtRandGen(seed) 96 | call f95_mt_gen%finalize() 97 | enddo 98 | call system_clock(c2, cr, cm); dt1 = dble(c2-c1)/dble(cr) 99 | 100 | f95_mt_gen = ShrF95MtRandGen(seed) 101 | call system_clock(c1, cr, cm) 102 | do m = 1,ntrials 103 | call f95_mt_gen%random(array) 104 | enddo 105 | call f95_mt_gen%finalize() 106 | call system_clock(c2, cr, cm); dt2 = dble(c2-c1)/dble(cr) 107 | dt = dt1+dt2 108 | print *, 'Init/term time (MT19937): ',dt1 109 | print *, 'Gen time (MT19937): ',dt2 110 | print *, 'Total time (MT19937): ',dt 111 | print *, 'MegaRNumbers (MT19937): ', 1.0e-6*dble(nstream*length*ntrials)/dt 112 | print *, 'Summation of Random Numbers: ', SUM(array) 113 | print *, '--------'; print *, '' 114 | 115 | ! fortran-90 intrinsic pseudorandom number generator 116 | 117 | call random_seed(size=intrinsic_size) 118 | allocate(intrinsic_seed(nstream,intrinsic_size)) 119 | do n = 1, nstream 120 | do i = 1, intrinsic_size 121 | intrinsic_seed(n,i) = seed(n)*i+n 122 | end do 123 | end do 124 | 125 | call system_clock(c1, cr, cm) 126 | do m = 1,ntrials 127 | intrinsic_gen = ShrIntrinsicRandGen(intrinsic_seed) 128 | call intrinsic_gen%finalize() 129 | enddo 130 | call system_clock(c2, cr, cm); dt1 = dble(c2-c1)/dble(cr) 131 | 132 | intrinsic_gen = ShrIntrinsicRandGen(intrinsic_seed) 133 | call system_clock(c1, cr, cm) 134 | do m = 1,ntrials 135 | call intrinsic_gen%random(array) 136 | enddo 137 | call intrinsic_gen%finalize() 138 | call system_clock(c2, cr, cm); dt2 = dble(c2-c1)/dble(cr) 139 | dt = dt1+dt2 140 | print *, 'Init/term time (F90_INTRINSIC): ',dt1 141 | print *, 'Gen time (F90_INTRINSIC): ',dt2 142 | print *, 'Total time (F90_INTRINSIC): ',dt 143 | print *, 'MegaRNumbers (F90_INTRINSIC): ', 1.0e-6*dble(nstream*length*ntrials)/dt 144 | print *, 'Summation of Random Numbers: ', SUM(array) 145 | print *, '--------'; print *, '' 146 | 147 | ! SIMD-orientated mersenne twister 148 | 149 | call system_clock(c1, cr, cm) 150 | do m = 1,ntrials 151 | dsfmt_gen = ShrDsfmtRandGen(seed, length) 152 | call dsfmt_gen%finalize() 153 | enddo 154 | call system_clock(c2, cr, cm); dt1 = dble(c2-c1)/dble(cr) 155 | 156 | dsfmt_gen = ShrDsfmtRandGen(seed, length) 157 | call system_clock(c1, cr, cm) 158 | do m = 1,ntrials 159 | call dsfmt_gen%random(array) 160 | enddo 161 | call dsfmt_gen%finalize() 162 | call system_clock(c2, cr, cm); dt2 = dble(c2-c1)/dble(cr) 163 | dt = dt1+dt2 164 | print *, 'Init/term time (DSFMT_F03): ',dt1 165 | print *, 'Gen time (DSFMT_F03): ',dt2 166 | print *, 'Total time (DSFMT_F03): ',dt 167 | print *, 'MegaRNumbers (DSFMT_F03): ', 1.0e-6*dble(nstream*length*ntrials)/dt 168 | print *, 'Summation of Random Numbers: ', SUM(array) 169 | print *, '--------'; print *, '' 170 | 171 | end program test 172 | -------------------------------------------------------------------------------- /test/unit/shr_assert_test/test_assert_array.pf: -------------------------------------------------------------------------------- 1 | module test_assert_array 2 | 3 | ! Test shr_assert_all and shr_assert_any. 4 | 5 | use funit 6 | 7 | use shr_assert_mod, only: & 8 | shr_assert_all, & 9 | shr_assert_any 10 | 11 | implicit none 12 | save 13 | 14 | @TestParameter 15 | type, extends(AbstractTestParameter) :: ArrayRank 16 | integer :: rank 17 | contains 18 | procedure :: toString 19 | end type ArrayRank 20 | 21 | @TestCase(testParameters={getParameters()}, constructor=new_TestAssertArray) 22 | type, extends(ParameterizedTestCase) :: TestAssertArray 23 | integer :: rank 24 | end type TestAssertArray 25 | 26 | contains 27 | 28 | function new_TestAssertArray(rank) result(test) 29 | type(ArrayRank), intent(in) :: rank 30 | type(TestAssertArray) :: test 31 | 32 | test%rank = rank%rank 33 | 34 | end function new_TestAssertArray 35 | 36 | function getParameters() result(params) 37 | type(ArrayRank), allocatable :: params(:) 38 | 39 | integer :: i 40 | 41 | params = [( ArrayRank(i), i = 1, 7 )] 42 | 43 | end function getParameters 44 | 45 | function toString(this) result(string) 46 | class(ArrayRank), intent(in) :: this 47 | character(:), allocatable :: string 48 | 49 | character(len=30) :: buffer 50 | 51 | write(buffer, '(A,I1,A)') "(rank = ",this%rank,")" 52 | 53 | string = trim(buffer) 54 | 55 | end function toString 56 | 57 | @Test 58 | subroutine assert_all_size_zero_passes(this) 59 | class(TestAssertArray), intent(inout) :: this 60 | call assert_all_wrapper([logical::], 0, this%rank, & 61 | "Assert unexpectedly aborted!") 62 | end subroutine assert_all_size_zero_passes 63 | 64 | @Test 65 | subroutine assert_all_can_pass(this) 66 | class(TestAssertArray), intent(inout) :: this 67 | call assert_all_wrapper([.true.], 1, this%rank, & 68 | "Assert unexpectedly aborted!") 69 | end subroutine assert_all_can_pass 70 | 71 | @Test 72 | subroutine assert_all_can_fail(this) 73 | class(TestAssertArray), intent(inout) :: this 74 | call assert_all_wrapper([.false.], 1, this%rank, & 75 | "Expected failure.") 76 | call assertExceptionRaised("ABORTED: ERROR: Expected failure.") 77 | end subroutine assert_all_can_fail 78 | 79 | @Test 80 | subroutine assert_all_partial_false_fails(this) 81 | class(TestAssertArray), intent(inout) :: this 82 | logical :: test_array(2**this%rank) 83 | integer :: i 84 | test_array = [( mod(i,2) == 0, i = 1, size(test_array) )] 85 | call assert_all_wrapper(test_array, 2, this%rank, & 86 | "Expected failure.") 87 | call assertExceptionRaised("ABORTED: ERROR: Expected failure.") 88 | end subroutine assert_all_partial_false_fails 89 | 90 | @Test 91 | subroutine assert_any_size_zero_fails(this) 92 | class(TestAssertArray), intent(inout) :: this 93 | call assert_any_wrapper([logical::], 0, this%rank, & 94 | "Expected failure.") 95 | call assertExceptionRaised("ABORTED: ERROR: Expected failure.") 96 | end subroutine assert_any_size_zero_fails 97 | 98 | @Test 99 | subroutine assert_any_can_pass(this) 100 | class(TestAssertArray), intent(inout) :: this 101 | call assert_any_wrapper([.true.], 1, this%rank, & 102 | "Assert unexpectedly aborted!") 103 | end subroutine assert_any_can_pass 104 | 105 | @Test 106 | subroutine assert_any_can_fail(this) 107 | class(TestAssertArray), intent(inout) :: this 108 | call assert_any_wrapper([.false.], 1, this%rank, & 109 | "Expected failure.") 110 | call assertExceptionRaised("ABORTED: ERROR: Expected failure.") 111 | end subroutine assert_any_can_fail 112 | 113 | @Test 114 | subroutine assert_any_partial_false_passes(this) 115 | class(TestAssertArray), intent(inout) :: this 116 | logical :: test_array(2**this%rank) 117 | integer :: i 118 | test_array = [( mod(i,2) == 0, i = 1, size(test_array) )] 119 | call assert_any_wrapper(test_array, 2, this%rank, & 120 | "Assert unexpectedly aborted!") 121 | end subroutine assert_any_partial_false_passes 122 | 123 | ! The wrappers are to allow rank-generic programming. 124 | ! The routines assert with the given array and message, but the array is 125 | ! resized to have "rank" dimensions of size "dimsize". 126 | 127 | subroutine assert_all_wrapper(array, dimsize, rank, msg) 128 | logical, intent(in) :: array(:) 129 | integer, intent(in) :: dimsize 130 | integer, intent(in) :: rank 131 | character(len=*), intent(in) :: msg 132 | 133 | integer :: i 134 | 135 | select case (rank) 136 | case(1) 137 | call shr_assert_all(reshape(array, [(dimsize, i = 1, 1)]), msg) 138 | case(2) 139 | call shr_assert_all(reshape(array, [(dimsize, i = 1, 2)]), msg) 140 | case(3) 141 | call shr_assert_all(reshape(array, [(dimsize, i = 1, 3)]), msg) 142 | case(4) 143 | call shr_assert_all(reshape(array, [(dimsize, i = 1, 4)]), msg) 144 | case(5) 145 | call shr_assert_all(reshape(array, [(dimsize, i = 1, 5)]), msg) 146 | case(6) 147 | call shr_assert_all(reshape(array, [(dimsize, i = 1, 6)]), msg) 148 | case(7) 149 | call shr_assert_all(reshape(array, [(dimsize, i = 1, 7)]), msg) 150 | case default 151 | call throw("assert_all_wrapper was given a bad rank.") 152 | end select 153 | 154 | end subroutine assert_all_wrapper 155 | 156 | subroutine assert_any_wrapper(array, dimsize, rank, msg) 157 | logical, intent(in) :: array(:) 158 | integer, intent(in) :: dimsize 159 | integer, intent(in) :: rank 160 | character(len=*), intent(in) :: msg 161 | 162 | integer :: i 163 | 164 | select case (rank) 165 | case(1) 166 | call shr_assert_any(reshape(array, [(dimsize, i = 1, 1)]), msg) 167 | case(2) 168 | call shr_assert_any(reshape(array, [(dimsize, i = 1, 2)]), msg) 169 | case(3) 170 | call shr_assert_any(reshape(array, [(dimsize, i = 1, 3)]), msg) 171 | case(4) 172 | call shr_assert_any(reshape(array, [(dimsize, i = 1, 4)]), msg) 173 | case(5) 174 | call shr_assert_any(reshape(array, [(dimsize, i = 1, 5)]), msg) 175 | case(6) 176 | call shr_assert_any(reshape(array, [(dimsize, i = 1, 6)]), msg) 177 | case(7) 178 | call shr_assert_any(reshape(array, [(dimsize, i = 1, 7)]), msg) 179 | case default 180 | call throw("assert_any_wrapper was given a bad rank.") 181 | end select 182 | 183 | end subroutine assert_any_wrapper 184 | 185 | end module test_assert_array 186 | -------------------------------------------------------------------------------- /cmake/FindESMF.cmake: -------------------------------------------------------------------------------- 1 | # - Try to find ESMF 2 | # 3 | # Uses ESMFMKFILE to find the filepath of esmf.mk. If this is NOT set, then this 4 | # module will attempt to find esmf.mk. If ESMFMKFILE exists, then 5 | # ESMF_FOUND=TRUE and all ESMF makefile variables will be set in the global 6 | # scope. Optionally, set ESMF_MKGLOBALS to a string list to filter makefile 7 | # variables. For example, to globally scope only ESMF_LIBSDIR and ESMF_APPSDIR 8 | # variables, use this CMake command in CMakeLists.txt: 9 | # 10 | # set(ESMF_MKGLOBALS "LIBSDIR" "APPSDIR") 11 | 12 | # Set ESMFMKFILE as defined by system env variable. If it's not explicitly set 13 | # try to find esmf.mk file in default locations (ESMF_ROOT, CMAKE_PREFIX_PATH, 14 | # etc) 15 | if(NOT DEFINED ESMFMKFILE) 16 | if(NOT DEFINED ENV{ESMFMKFILE}) 17 | find_path(ESMFMKFILE_PATH esmf.mk PATH_SUFFIXES lib lib64) 18 | if(ESMFMKFILE_PATH) 19 | set(ESMFMKFILE ${ESMFMKFILE_PATH}/esmf.mk) 20 | message(STATUS "Found esmf.mk file ${ESMFMKFILE}") 21 | endif() 22 | else() 23 | set(ESMFMKFILE $ENV{ESMFMKFILE}) 24 | endif() 25 | endif() 26 | 27 | # Only parse the mk file if it is found 28 | if(EXISTS ${ESMFMKFILE}) 29 | set(ESMFMKFILE ${ESMFMKFILE} CACHE FILEPATH "Path to esmf.mk file") 30 | set(ESMF_FOUND TRUE CACHE BOOL "esmf.mk file found" FORCE) 31 | 32 | # Read the mk file 33 | file(STRINGS "${ESMFMKFILE}" esmfmkfile_contents) 34 | # Parse each line in the mk file 35 | foreach(str ${esmfmkfile_contents}) 36 | # Only consider uncommented lines 37 | string(REGEX MATCH "^[^#]" def ${str}) 38 | # Line is not commented 39 | if(def) 40 | # Extract the variable name 41 | string(REGEX MATCH "^[^=]+" esmf_varname ${str}) 42 | # Extract the variable's value 43 | string(REGEX MATCH "=.+$" esmf_vardef ${str}) 44 | # Only for variables with a defined value 45 | if(esmf_vardef) 46 | # Get rid of the assignment string 47 | string(SUBSTRING ${esmf_vardef} 1 -1 esmf_vardef) 48 | # Remove whitespace 49 | string(STRIP ${esmf_vardef} esmf_vardef) 50 | # A string or single-valued list 51 | if(NOT DEFINED ESMF_MKGLOBALS) 52 | # Set in global scope 53 | set(${esmf_varname} ${esmf_vardef}) 54 | # Don't display by default in GUI 55 | mark_as_advanced(esmf_varname) 56 | else() # Need to filter global promotion 57 | foreach(m ${ESMF_MKGLOBALS}) 58 | string(FIND ${esmf_varname} ${m} match) 59 | # Found the string 60 | if(NOT ${match} EQUAL -1) 61 | # Promote to global scope 62 | set(${esmf_varname} ${esmf_vardef}) 63 | # Don't display by default in the GUI 64 | mark_as_advanced(esmf_varname) 65 | # No need to search for the current string filter 66 | break() 67 | endif() 68 | endforeach() 69 | endif() 70 | endif() 71 | endif() 72 | endforeach() 73 | 74 | # Construct ESMF_VERSION from ESMF_VERSION_STRING_GIT 75 | # ESMF_VERSION_MAJOR and ESMF_VERSION_MINOR are defined in ESMFMKFILE 76 | set(ESMF_VERSION 0) 77 | set(ESMF_VERSION_PATCH ${ESMF_VERSION_REVISION}) 78 | set(ESMF_BETA_RELEASE FALSE) 79 | if(ESMF_VERSION_BETASNAPSHOT MATCHES "^('T')$") 80 | set(ESMF_BETA_RELEASE TRUE) 81 | if(ESMF_VERSION_STRING_GIT MATCHES "^ESMF.*beta_snapshot") 82 | set(ESMF_BETA_SNAPSHOT ${ESMF_VERSION_STRING_GIT}) 83 | elseif(ESMF_VERSION_STRING_GIT MATCHES "^v.\..\..b") 84 | set(ESMF_BETA_SNAPSHOT ${ESMF_VERSION_STRING_GIT}) 85 | else() 86 | set(ESMF_BETA_SNAPSHOT 0) 87 | endif() 88 | message(STATUS "Detected ESMF Beta snapshot: ${ESMF_BETA_SNAPSHOT}") 89 | endif() 90 | set(ESMF_VERSION "${ESMF_VERSION_MAJOR}.${ESMF_VERSION_MINOR}.${ESMF_VERSION_PATCH}") 91 | 92 | # Find the ESMF library 93 | if(USE_ESMF_STATIC_LIBS) 94 | find_library(ESMF_LIBRARY_LOCATION NAMES libesmf.a PATHS ${ESMF_LIBSDIR} NO_DEFAULT_PATH) 95 | if(ESMF_LIBRARY_LOCATION MATCHES "ESMF_LIBRARY_LOCATION-NOTFOUND") 96 | message(WARNING "Static ESMF library (libesmf.a) not found in \ 97 | ${ESMF_LIBSDIR}. Try setting USE_ESMF_STATIC_LIBS=OFF") 98 | endif() 99 | if(NOT TARGET ESMF) 100 | add_library(ESMF STATIC IMPORTED) 101 | endif() 102 | else() 103 | find_library(ESMF_LIBRARY_LOCATION NAMES esmf PATHS ${ESMF_LIBSDIR} NO_DEFAULT_PATH) 104 | if(ESMF_LIBRARY_LOCATION MATCHES "ESMF_LIBRARY_LOCATION-NOTFOUND") 105 | message(WARNING "ESMF library not found in ${ESMF_LIBSDIR}.") 106 | endif() 107 | if(NOT TARGET ESMF) 108 | add_library(ESMF UNKNOWN IMPORTED) 109 | endif() 110 | endif() 111 | 112 | # Add target alias to facilitate unambiguous linking 113 | if(NOT TARGET ESMF::ESMF) 114 | add_library(ESMF::ESMF ALIAS ESMF) 115 | endif() 116 | 117 | # Add ESMF include directories 118 | set(ESMF_INCLUDE_DIRECTORIES "") 119 | separate_arguments(_ESMF_F90COMPILEPATHS UNIX_COMMAND ${ESMF_F90COMPILEPATHS}) 120 | foreach(_ITEM ${_ESMF_F90COMPILEPATHS}) 121 | string(REGEX REPLACE "^-I" "" _ITEM "${_ITEM}") 122 | list(APPEND ESMF_INCLUDE_DIRECTORIES ${_ITEM}) 123 | endforeach() 124 | 125 | # Add ESMF link libraries 126 | string(STRIP "${ESMF_F90LINKRPATHS} ${ESMF_F90ESMFLINKRPATHS} ${ESMF_F90ESMFLINKPATHS} ${ESMF_F90LINKPATHS} ${ESMF_F90LINKLIBS} ${ESMF_F90LINKOPTS}" ESMF_INTERFACE_LINK_LIBRARIES) 127 | 128 | # Finalize find_package 129 | include(FindPackageHandleStandardArgs) 130 | 131 | find_package_handle_standard_args( 132 | ${CMAKE_FIND_PACKAGE_NAME} 133 | REQUIRED_VARS ESMF_LIBRARY_LOCATION 134 | ESMF_INTERFACE_LINK_LIBRARIES 135 | ESMF_F90COMPILEPATHS 136 | VERSION_VAR ESMF_VERSION) 137 | 138 | set_target_properties(ESMF PROPERTIES 139 | IMPORTED_LOCATION "${ESMF_LIBRARY_LOCATION}" 140 | INTERFACE_INCLUDE_DIRECTORIES "${ESMF_INCLUDE_DIRECTORIES}" 141 | INTERFACE_LINK_LIBRARIES "${ESMF_INTERFACE_LINK_LIBRARIES}") 142 | 143 | else() 144 | set(ESMF_FOUND FALSE CACHE BOOL "esmf.mk file NOT found" FORCE) 145 | message(WARNING "ESMFMKFILE ${ESMFMKFILE} not found. Try setting ESMFMKFILE \ 146 | to esmf.mk location.") 147 | endif() 148 | -------------------------------------------------------------------------------- /.github/workflows/extbuild.yml: -------------------------------------------------------------------------------- 1 | # This is a workflow to compile the share source without cime 2 | name: extbuild 3 | # Controls when the action will run. Triggers the workflow on push or pull request 4 | # events but only for the main branch 5 | on: 6 | push: 7 | branches: [ main ] 8 | pull_request: 9 | branches: [ main ] 10 | 11 | # A workflow run is made up of one or more jobs that can run sequentially or in parallel 12 | jobs: 13 | build-share: 14 | runs-on: ubuntu-latest 15 | env: 16 | CC: mpicc 17 | FC: mpifort 18 | CXX: mpicxx 19 | CPPFLAGS: "-I/usr/include -I/usr/local/include " 20 | LDFLAGS: "-L/usr/lib/x86_64-linux-gnu " 21 | CIME_MODEL: cesm 22 | CIME_MACHINE: ubuntu-latest 23 | # Versions of all dependencies can be updated here - these match tag names in the github repo 24 | ESMF_VERSION: v8.6.1 25 | ParallelIO_VERSION: pio2_6_2 26 | PFUNIT_VERSION: v4.9.0 27 | steps: 28 | - id: checkout-share 29 | uses: actions/checkout@v4 30 | - id: load-env 31 | run: | 32 | sudo apt-get update 33 | sudo apt-get install -y cmake 34 | sudo apt-get install -y gfortran 35 | sudo apt-get install -y openmpi-bin libopenmpi-dev 36 | sudo apt-get install -y libxml2-utils 37 | sudo apt-get install -y netcdf-bin libnetcdf-dev libnetcdff-dev 38 | sudo apt-get install -y pnetcdf-bin libpnetcdf-dev 39 | sudo apt-get install -y libblas-dev 40 | - name: Checkout CIME 41 | uses: actions/checkout@v4 42 | with: 43 | repository: ESMCI/cime 44 | path: cime 45 | - name: Checkout ccs_config 46 | uses: actions/checkout@v4 47 | with: 48 | repository: ESMCI/ccs_config_cesm 49 | path: ccs_config 50 | - name: Cache PARALLELIO 51 | id: cache-PARALLELIO 52 | uses: actions/cache@v4 53 | with: 54 | path: pio 55 | key: ${{ runner.os }}-${{ env.ParallelIO_VERSION }} 56 | - name: Build ParallelIO 57 | if: steps.cache-PARALLELIO.outputs.cache-hit != 'true' 58 | uses: NCAR/ParallelIO/.github/actions/parallelio_cmake@9390e30e29d4ebbfbef0fc72162cacd9e8f25e4e 59 | with: 60 | parallelio_version: ${{ env.ParallelIO_VERSION }} 61 | enable_fortran: True 62 | install_prefix: ${GITHUB_WORKSPACE}/pio 63 | - name: Install ESMF 64 | uses: esmf-org/install-esmf-action@v1 65 | env: 66 | ESMF_COMPILER: gfortran 67 | ESMF_BOPT: g 68 | ESMF_COMM: openmpi 69 | ESMF_NETCDF: nc-config 70 | ESMF_PNETCDF: pnetcdf-config 71 | ESMF_INSTALL_PREFIX: ${GITHUB_WORKSPACE}/ESMF 72 | ESMF_PIO: external 73 | ESMF_PIO_INCLUDE: ${GITHUB_WORKSPACE}/pio/include 74 | ESMF_PIO_LIBPATH: ${GITHUB_WORKSPACE}/pio/lib 75 | with: 76 | version: ${{ env.ESMF_VERSION }} 77 | esmpy: false 78 | cache: true 79 | 80 | - name: Cache PFUNIT 81 | id: cache-pfunit 82 | uses: actions/cache@v4 83 | with: 84 | path: pfunit 85 | key: ${{ runner.os }}-${{ env.PFUNIT_VERSION }} 86 | - name: Checkout PFUNIT 87 | if: steps.cache-pfunit.outputs.cache-hit != 'true' 88 | uses: actions/checkout@v4 89 | with: 90 | path: pfunit 91 | ref: ${{ env.PFUNIT_VERSION }} 92 | repository: Goddard-Fortran-Ecosystem/pFUnit 93 | - name: build PFUNIT 94 | if: steps.cache-pfunit.outputs.cache-hit != 'true' 95 | run: | 96 | pushd pfunit 97 | cmake -DSKIP_MPI=YES -DSKIP_OPENMP=YES -B build 98 | cmake --build build 99 | popd 100 | 101 | # Note that we have two steps below, which exercise different aspects of the build: 102 | # - The "Build SHARE" step builds share without unit tests, and only uses CIME for 103 | # the sake of some CMake functions and genf90, NOT using CIME / ccs_config for 104 | # machine configuration. This is useful to ensure that we can do the build in a 105 | # relatively simple way, without relying on CIME-generated Macros. 106 | # - The "Test share" step redoes the build and runs the unit tests using 107 | # run_tests.py, leveraging the Macros generated by CIME / ccs_config. So, in 108 | # addition to ensuring that the unit tests pass, this step is also useful in 109 | # ensuring that we can build the share code leveraging CIME-generated Macros. 110 | # 111 | # We could test more permutations of this - e.g., testing the build using 112 | # CIME-generated Macros without building and running the unit tests, or building and 113 | # running the unit tests without using the CIME-generated Macros (and for either of 114 | # these, we could choose to use or not use run_tests.py - though note that, if we 115 | # didn't use run_tests.py, we would need to generate the Macros file in a different 116 | # way). But for now these two combinations seem sufficient. 117 | - name: Build SHARE 118 | uses: ./.github/actions/buildshare 119 | with: 120 | esmfmkfile: $ESMFMKFILE 121 | cime_path: ${GITHUB_WORKSPACE}/cime 122 | pio_path: ${GITHUB_WORKSPACE}/pio 123 | src_root: ${GITHUB_WORKSPACE} 124 | pfunit_root: ${GITHUB_WORKSPACE}/pfunit 125 | cmake_flags: " -Wno-dev -DCMAKE_BUILD_TYPE=DEBUG -DWERROR=ON \ 126 | -DCMAKE_Fortran_FLAGS=\" -g -Wall -ffree-form -ffree-line-length-none -fallow-argument-mismatch\" \ 127 | -DCMAKE_MODULE_PATH=$ESMF_ROOT/cmake" 128 | - name: Test share 129 | run: | 130 | export PFUNIT_PATH=${GITHUB_WORKSPACE}/pfunit/build 131 | export PIO_ROOT=${GITHUB_WORKSPACE}/pio 132 | ${GITHUB_WORKSPACE}/cime/scripts/fortran_unit_testing/run_tests.py --build-dir ./unit_tests.temp --cmake-args " -DUNITTESTS=ON -DUSE_CIME_MACROS=ON" --mpilib openmpi 133 | 134 | # the following can be used by developers to login to the github server in case of errors 135 | # see https://github.com/marketplace/actions/debugging-with-tmate for further details 136 | - name: Setup tmate session 137 | if: ${{ failure() }} 138 | uses: mxschmitt/action-tmate@v3 139 | 140 | -------------------------------------------------------------------------------- /src/water_isotopes/water_types.F90: -------------------------------------------------------------------------------- 1 | module water_types 2 | 3 | !----------------------------------------------------------------------- 4 | ! 5 | ! Provide core functionality for types of condensed water to be used 6 | ! with the water vapor tracers. 7 | ! 8 | ! This module works in with "water_isotopes" and "water_tracers". 9 | ! 10 | ! All interface routine are identified by wtype_*, etc. 11 | ! 12 | ! 5 types of water are available, three phases (vapor, cloud liquid 13 | ! and cloud ice) and precipitation (rain and snow). 14 | ! 15 | ! Author: Chuck Bardeen (2/4/2012) 16 | !----------------------------------------------------------------------- 17 | use shr_kind_mod, only: r8 => shr_kind_r8 18 | 19 | implicit none 20 | 21 | private 22 | save 23 | 24 | !------------------------ Module Interfaces ----------------------------- 25 | ! 26 | ! Public interfaces 27 | ! 28 | public :: wtype_init ! initilize water types 29 | public :: wtype_get_itype ! lookup a species index by name 30 | 31 | public :: wtype_get_alpha ! isotope fractionation 32 | 33 | 34 | !------------------- Module Variable Declarations ----------------------- 35 | ! 36 | ! Water tracer type identifiers 37 | integer, parameter, public :: pwtype = 7 ! number of water types 38 | 39 | integer, parameter, public :: iwtundef = 0 ! not water type 40 | integer, parameter, public :: iwtvap = 1 ! water type is vapour 41 | integer, parameter, public :: iwtliq = 2 ! water type is liquid 42 | integer, parameter, public :: iwtice = 3 ! water type is ice 43 | integer, parameter, public :: iwtstrain = 4 ! water type is stratiform rain 44 | integer, parameter, public :: iwtstsnow = 5 ! water type is stratiform snow 45 | integer, parameter, public :: iwtcvrain = 6 ! water type is convective rain 46 | integer, parameter, public :: iwtcvsnow = 7 ! water type is convective snow 47 | 48 | ! Water type names 49 | character(len=8), dimension(pwtype), parameter, public :: & ! water type names 50 | wtype_names = (/ 'VAPOR ', 'LIQUID ', 'ICE ', 'RAINS ', 'SNOWS ', 'RAINC ', 'SNOWC ' /) 51 | 52 | ! Water type Suffix 53 | character(len=2), dimension(pwtype), parameter, public :: & ! suffix names 54 | wtype_suffix = (/ '_v', '_l', '_i', '_R', '_S', '_r', '_s' /) 55 | 56 | 57 | ! 58 | !----------------------------------------------------------------------- 59 | contains 60 | 61 | !======================================================================= 62 | subroutine wtype_init 63 | !----------------------------------------------------------------------- 64 | ! Purpose: Initialize module internal data arrays 65 | !----------------------------------------------------------------------- 66 | write(6,*) 'WTYPE_INIT: Initializing water types.' 67 | return 68 | end subroutine wtype_init 69 | 70 | 71 | !======================================================================= 72 | function wtype_get_itype(name) 73 | !----------------------------------------------------------------------- 74 | ! Purpose: Retrieve type index, based on type name 75 | ! Author: Chuck Bardeen 76 | !----------------------------------------------------------------------- 77 | character(len=*), intent(in) :: name ! water type name 78 | integer :: wtype_get_itype ! return species index 79 | !----------------------------------------------------------------------- 80 | do wtype_get_itype = 1, pwtype 81 | if (name == wtype_names(wtype_get_itype)) then 82 | return 83 | end if 84 | end do 85 | 86 | wtype_get_itype = iwtundef 87 | 88 | return 89 | end function wtype_get_itype 90 | 91 | !========================================================================= 92 | 93 | 94 | !======================================================================= 95 | function wtype_get_alpha(ispec, isrctype, idsttype, tk, rh, do_kinetic) 96 | !----------------------------------------------------------------------- 97 | ! Purpose: Retrieve the fractionation for a process that goes from 98 | ! the source water type to the destination water type. 99 | ! 100 | ! Author: Chuck Bardeen 101 | !----------------------------------------------------------------------- 102 | use water_isotopes, only : wiso_alpl, wiso_alpi, wiso_akel, wiso_akci 103 | 104 | integer, intent(in) :: ispec ! isotope species index 105 | integer, intent(in) :: isrctype ! source water type index 106 | integer, intent(in) :: idsttype ! destination water type index 107 | real(r8), intent(in) :: tk ! temperature (K) 108 | real(r8), intent(in) :: rh ! relative humidity (fraction) 109 | logical, intent(in) :: do_kinetic ! use kinetic calculation 110 | real(r8) :: wtype_get_alpha ! return alpha 111 | 112 | !----------------------------------------------------------------------- 113 | 114 | ! If their types are the same, then no fractionation occurs. 115 | wtype_get_alpha = 1._r8 116 | 117 | if (isrctype /= idsttype) then 118 | 119 | ! Is the source vapor? 120 | if (isrctype == iwtvap) then 121 | 122 | ! Is the destination a liquid? 123 | if ((idsttype == iwtliq) .or. (idsttype == iwtstrain) .or. (idsttype == iwtcvrain)) then 124 | wtype_get_alpha = wiso_alpl(ispec,tk) 125 | 126 | if (do_kinetic) then 127 | wtype_get_alpha = wiso_akel(ispec,tk,rh,wtype_get_alpha) 128 | end if 129 | else 130 | wtype_get_alpha = wiso_alpi(ispec,tk) 131 | 132 | if (do_kinetic) then 133 | wtype_get_alpha = wiso_akci(ispec,tk,wtype_get_alpha) 134 | end if 135 | end if 136 | 137 | ! Is the destination vapor? 138 | else if (idsttype == iwtvap) then 139 | 140 | ! Is the source a liquid? 141 | if ((isrctype == iwtliq) .or. (isrctype == iwtstrain) .or. (isrctype == iwtcvrain)) then 142 | wtype_get_alpha = wiso_alpl(ispec,tk) 143 | 144 | if (do_kinetic) then 145 | wtype_get_alpha = wiso_akel(ispec,tk,rh,wtype_get_alpha) 146 | end if 147 | wtype_get_alpha = 1._r8 / wtype_get_alpha 148 | else 149 | wtype_get_alpha = 1._r8 !No fractionation occurs during sublimation 150 | end if 151 | end if 152 | end if 153 | 154 | return 155 | end function wtype_get_alpha 156 | 157 | !========================================================================= 158 | 159 | end module water_types 160 | -------------------------------------------------------------------------------- /src/shr_const_mod.F90: -------------------------------------------------------------------------------- 1 | !=============================================================================== 2 | ! SVN $Id: shr_const_mod.F90 61510 2014-06-26 21:58:56Z tcraig $ 3 | ! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_const_mod.F90 $ 4 | !=============================================================================== 5 | 6 | MODULE shr_const_mod 7 | 8 | use shr_kind_mod, only : R8 => shr_kind_r8 9 | 10 | !---------------------------------------------------------------------------- 11 | ! physical constants (all data public) 12 | !---------------------------------------------------------------------------- 13 | private :: R8 14 | public 15 | 16 | real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 ! pi 17 | real(R8),parameter :: SHR_CONST_CDAY = 86400.0_R8 ! sec in calendar day ~ sec 18 | real(R8),parameter :: SHR_CONST_SDAY = 86164.0_R8 ! sec in siderial day ~ sec 19 | real(R8),parameter :: SHR_CONST_OMEGA = 2.0_R8*SHR_CONST_PI/SHR_CONST_SDAY ! earth rot ~ rad/sec 20 | real(R8),parameter :: SHR_CONST_REARTH = 6.37122e6_R8 ! radius of earth ~ m 21 | real(R8),parameter :: SHR_CONST_G = 9.80616_R8 ! acceleration of gravity ~ m/s^2 22 | 23 | real(R8),parameter :: SHR_CONST_STEBOL = 5.67e-8_R8 ! Stefan-Boltzmann constant ~ W/m^2/K^4 24 | real(R8),parameter :: SHR_CONST_BOLTZ = 1.38065e-23_R8 ! Boltzmann's constant ~ J/K/molecule 25 | real(R8),parameter :: SHR_CONST_AVOGAD = 6.02214e26_R8 ! Avogadro's number ~ molecules/kmole 26 | real(R8),parameter :: SHR_CONST_RGAS = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ ! Universal gas constant ~ J/K/kmole 27 | real(R8),parameter :: SHR_CONST_MWDAIR = 28.966_R8 ! molecular weight dry air ~ kg/kmole 28 | real(R8),parameter :: SHR_CONST_MWWV = 18.016_R8 ! molecular weight water vapor 29 | real(R8),parameter :: SHR_CONST_RDAIR = SHR_CONST_RGAS/SHR_CONST_MWDAIR ! Dry air gas constant ~ J/K/kg 30 | real(R8),parameter :: SHR_CONST_RWV = SHR_CONST_RGAS/SHR_CONST_MWWV ! Water vapor gas constant ~ J/K/kg 31 | real(R8),parameter :: SHR_CONST_ZVIR = (SHR_CONST_RWV/SHR_CONST_RDAIR)-1.0_R8 ! RWV/RDAIR - 1.0 32 | real(R8),parameter :: SHR_CONST_KARMAN = 0.4_R8 ! Von Karman constant 33 | real(R8),parameter :: SHR_CONST_PSTD = 101325.0_R8 ! standard pressure ~ pascals 34 | real(R8),parameter :: SHR_CONST_PDB = 0.0112372_R8 ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard) 35 | 36 | real(R8),parameter :: SHR_CONST_TKTRIP = 273.16_R8 ! triple point of fresh water ~ K 37 | real(R8),parameter :: SHR_CONST_TKFRZ = 273.15_R8 ! freezing T of fresh water ~ K 38 | real(R8),parameter :: SHR_CONST_TKFRZSW = SHR_CONST_TKFRZ - 1.8_R8 ! freezing T of salt water ~ K 39 | real(R8),parameter :: SHR_CONST_ZSRFLYR = 3.0_R8 ! ocn surf layer depth for diurnal SST cal ~ m 40 | 41 | real(R8),parameter :: SHR_CONST_RHODAIR = & ! density of dry air at STP ~ kg/m^3 42 | SHR_CONST_PSTD/(SHR_CONST_RDAIR*SHR_CONST_TKFRZ) 43 | real(R8),parameter :: SHR_CONST_RHOFW = 1.000e3_R8 ! density of fresh water ~ kg/m^3 44 | real(R8),parameter :: SHR_CONST_RHOSW = 1.026e3_R8 ! density of sea water ~ kg/m^3 45 | real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice ~ kg/m^3 46 | real(R8),parameter :: SHR_CONST_CPDAIR = 1.00464e3_R8 ! specific heat of dry air ~ J/kg/K 47 | real(R8),parameter :: SHR_CONST_CPWV = 1.810e3_R8 ! specific heat of water vap ~ J/kg/K 48 | real(R8),parameter :: SHR_CONST_CPVIR = (SHR_CONST_CPWV/SHR_CONST_CPDAIR)-1.0_R8 ! CPWV/CPDAIR - 1.0 49 | real(R8),parameter :: SHR_CONST_CPFW = 4.188e3_R8 ! specific heat of fresh h2o ~ J/kg/K 50 | real(R8),parameter :: SHR_CONST_CPSW = 3.996e3_R8 ! specific heat of sea h2o ~ J/kg/K 51 | real(R8),parameter :: SHR_CONST_CPICE = 2.11727e3_R8 ! specific heat of fresh ice ~ J/kg/K 52 | real(R8),parameter :: SHR_CONST_LATICE = 3.337e5_R8 ! latent heat of fusion ~ J/kg 53 | real(R8),parameter :: SHR_CONST_LATVAP = 2.501e6_R8 ! latent heat of evaporation ~ J/kg 54 | real(R8),parameter :: SHR_CONST_LATSUB = & ! latent heat of sublimation ~ J/kg 55 | SHR_CONST_LATICE + SHR_CONST_LATVAP 56 | real(R8),parameter :: SHR_CONST_CONDICE = 2.1_R8 ! thermal conductivity of ice ~ W/m/K 57 | real(R8),parameter :: SHR_CONST_KAPPA_LAND_ICE = & ! Diffusivity of heat in land ice ~ 58 | SHR_CONST_CONDICE / (SHR_CONST_RHOICE*SHR_CONST_CPICE) 59 | real(R8),parameter :: SHR_CONST_TF0 = 6.22e-2_R8 ! The freezing temperature at zero pressure in 60 | ! sub-ice-shelf ocean cavities ~ C 61 | real(R8),parameter :: SHR_CONST_DTF_DP = -7.43e-8_R8 ! The coefficient for the term proportional to the (limited) 62 | ! pressure in the freezing temperature in sub-ice-shelf ocean cavities. ~ C Pa^{-1} 63 | real(R8),parameter :: SHR_CONST_DTF_DS = -5.63e-2_R8 !The coefficient for the term proportional to salinity in 64 | ! the freezing temperature in sub-ice-ice ocean cavities ~ C PSU^{-1} 65 | real(R8),parameter :: SHR_CONST_DTF_DPDS = -1.74e-10_R8 ! The coefficient for the term proportional to salinity times 66 | ! pressure in the freezing temperature in sub-ice-shelf ocean cavities ~ C PSU^{-1} Pa^{-1} 67 | real(R8),parameter :: SHR_CONST_OCN_REF_SAL = 34.7_R8 ! ocn ref salinity (psu) 68 | real(R8),parameter :: SHR_CONST_ICE_REF_SAL = 4.0_R8 ! ice ref salinity (psu) 69 | 70 | real(R8),parameter :: SHR_CONST_SPVAL = 1.0e30_R8 ! special missing value 71 | real(R8),parameter :: SHR_CONST_SPVAL_TOLMIN = 0.99_R8 * SHR_CONST_SPVAL ! min spval tolerance 72 | real(R8),parameter :: SHR_CONST_SPVAL_TOLMAX = 1.01_R8 * SHR_CONST_SPVAL ! max spval tolerance 73 | real(R8),parameter :: SHR_CONST_SPVAL_AERODEP= 1.e29_r8 ! special aerosol deposition 74 | 75 | !Water Isotope Ratios in Vienna Standard Mean Ocean Water (VSMOW): 76 | real(R8),parameter :: SHR_CONST_VSMOW_18O = 2005.2e-6_R8 ! 18O/16O in VMSOW 77 | real(R8),parameter :: SHR_CONST_VSMOW_17O = 379.e-6_R8 ! 18O/16O in VMSOW 78 | real(R8),parameter :: SHR_CONST_VSMOW_16O = 0.997628_R8 ! 16O/Tot in VMSOW 79 | real(R8),parameter :: SHR_CONST_VSMOW_D = 155.76e-6_R8 ! 2H/1H in VMSOW 80 | real(R8),parameter :: SHR_CONST_VSMOW_T = 1.85e-6_R8 ! 3H/1H in VMSOW 81 | real(R8),parameter :: SHR_CONST_VSMOW_H = 0.99984426_R8 ! 1H/Tot in VMSOW 82 | ! For best numerics in CAM5 83 | real(R8),parameter :: SHR_CONST_RSTD_H2ODEV = 1.0_R8 ! Rstd Dev Use 84 | 85 | contains 86 | 87 | !----------------------------------------------------------------------------- 88 | 89 | elemental logical function shr_const_isspval(rval) 90 | !$omp declare simd(shr_const_isspval) 91 | 92 | real(r8), intent(in) :: rval 93 | 94 | if (rval > SHR_CONST_SPVAL_TOLMIN .and. & 95 | rval < SHR_CONST_SPVAL_TOLMAX) then 96 | shr_const_isspval = .true. 97 | else 98 | shr_const_isspval = .false. 99 | endif 100 | 101 | end function shr_const_isspval 102 | 103 | !----------------------------------------------------------------------------- 104 | 105 | END MODULE shr_const_mod 106 | -------------------------------------------------------------------------------- /src/shr_vmath_mod.F90: -------------------------------------------------------------------------------- 1 | !=============================================================================== 2 | ! SVN $Id: shr_vmath_mod.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ 3 | ! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_vmath_mod.F90 $ 4 | !=============================================================================== 5 | ! PURPOSE: 6 | ! provides a uniform, platform-independent API for vector math functions 7 | !=============================================================================== 8 | 9 | module shr_vmath_mod 10 | 11 | !---------------------------------------------------------------------------- 12 | ! routines that evaluate various math functions for vector arguments 13 | ! intended to provide platform independent access to vendor optimized code 14 | !---------------------------------------------------------------------------- 15 | 16 | use shr_kind_mod 17 | use shr_log_mod, only: s_loglev => shr_log_Level 18 | use shr_log_mod, only: s_logunit => shr_log_Unit 19 | 20 | implicit none 21 | 22 | private 23 | public :: shr_vmath_sqrt, & 24 | shr_vmath_exp, shr_vmath_log, & 25 | shr_vmath_sin, shr_vmath_cos, & 26 | shr_vmath_rsqrt, shr_vmath_div 27 | 28 | contains 29 | 30 | !=============================================================================== 31 | 32 | subroutine shr_vmath_sqrt(X, Y, n) 33 | 34 | !----- arguments --- 35 | integer(SHR_KIND_IN),intent(in) :: n ! vector length 36 | real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument 37 | real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument 38 | 39 | !------------------------------------------------------------------------------- 40 | ! PURPOSE: sqrt for vector arguments, optimized on different platforms 41 | !------------------------------------------------------------------------------- 42 | #ifndef NO_SHR_VMATH 43 | #if (defined CPRINTEL) 44 | call vdsqrt(n, X, Y) 45 | return 46 | #endif 47 | 48 | #if (defined AIX) 49 | call vsqrt(Y, X, n) 50 | return 51 | #endif 52 | 53 | #endif 54 | Y = sqrt(X) 55 | return 56 | 57 | end subroutine shr_vmath_sqrt 58 | 59 | !=============================================================================== 60 | 61 | subroutine shr_vmath_rsqrt(X, Y, n) 62 | 63 | !----- arguments --- 64 | integer(SHR_KIND_IN),intent(in) :: n ! vector length 65 | real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument 66 | real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument 67 | 68 | !------------------------------------------------------------------------------- 69 | ! PURPOSE: reciprical sqrt for vector arguments, optimized on different platforms 70 | !------------------------------------------------------------------------------- 71 | 72 | #ifndef NO_SHR_VMATH 73 | #if (defined AIX) 74 | call vrsqrt(Y, X, n) 75 | return 76 | #endif 77 | !#ifdef CPRINTEL 78 | ! Does not pass unit tests 79 | ! real (SHR_KIND_R8) :: RX(n) ! 80 | ! call vdsqrt(n, X, RX) 81 | ! call vddiv(n, 1.0_SHR_KIND_R8,RX, Y) 82 | ! return 83 | !#endif 84 | #endif 85 | Y = 1.0_SHR_KIND_R8/sqrt(X) 86 | 87 | 88 | end subroutine shr_vmath_rsqrt 89 | 90 | !=============================================================================== 91 | 92 | subroutine shr_vmath_exp(X, Y, n) 93 | 94 | !----- arguments --- 95 | integer(SHR_KIND_IN),intent(in) :: n ! vector length 96 | real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument 97 | real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument 98 | 99 | !------------------------------------------------------------------------------- 100 | ! PURPOSE: exp for vector arguments, optimized on different platforms 101 | !------------------------------------------------------------------------------- 102 | 103 | #ifndef NO_SHR_VMATH 104 | #if (defined CPRINTEL) 105 | call vdexp(n, X, Y) 106 | return 107 | #endif 108 | #if (defined AIX) 109 | call vexp(Y, X, n) 110 | return 111 | #endif 112 | #endif 113 | 114 | Y = exp(X) 115 | return 116 | 117 | end subroutine shr_vmath_exp 118 | 119 | !=============================================================================== 120 | 121 | subroutine shr_vmath_div(X, Y, Z, n) 122 | !----- arguments --- 123 | integer(SHR_KIND_IN),intent(in) :: n ! vector length 124 | real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument 125 | real (SHR_KIND_R8),intent(in) :: Y(n) ! input vector argument 126 | real (SHR_KIND_R8),intent(out) :: Z(n) ! output vector argument 127 | integer :: i 128 | #ifndef NO_SHR_VMATH 129 | #if (defined CPRINTEL) 130 | call vddiv(n, X, Y, Z) 131 | return 132 | #endif 133 | 134 | #if (defined AIX) 135 | call vdiv(Z,X,Y,n) 136 | return 137 | #endif 138 | #endif 139 | 140 | do i=1,n 141 | Z(i) = X(i)/Y(i) 142 | enddo 143 | return 144 | end subroutine shr_vmath_div 145 | 146 | !=============================================================================== 147 | 148 | subroutine shr_vmath_log(X, Y, n) 149 | 150 | !----- arguments --- 151 | integer(SHR_KIND_IN),intent(in) :: n ! vector length 152 | real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument 153 | real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument 154 | 155 | !------------------------------------------------------------------------------- 156 | ! PURPOSE: log for vector arguments, optimized on different platforms 157 | !------------------------------------------------------------------------------- 158 | #ifndef NO_SHR_VMATH 159 | #if (defined AIX) 160 | call vlog(Y, X, n) 161 | return 162 | #endif 163 | #if (defined CPRINTEL) 164 | call vdln(n, X, Y) 165 | return 166 | #endif 167 | #endif 168 | Y = log(X) 169 | return 170 | 171 | 172 | end subroutine shr_vmath_log 173 | 174 | !=============================================================================== 175 | 176 | subroutine shr_vmath_sin(X, Y, n) 177 | 178 | !----- arguments --- 179 | integer(SHR_KIND_IN),intent(in) :: n ! vector length 180 | real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument 181 | real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument 182 | 183 | !------------------------------------------------------------------------------- 184 | ! PURPOSE: sin for vector arguments, optimized on different platforms 185 | !------------------------------------------------------------------------------- 186 | 187 | #ifndef NO_SHR_VMATH 188 | #if (defined AIX) 189 | call vsin(Y, X, n) 190 | return 191 | #endif 192 | 193 | #if (defined CPRINTEL) 194 | call vdsin(n, X, Y) 195 | return 196 | #endif 197 | #endif 198 | Y = sin(X) 199 | return 200 | 201 | end subroutine shr_vmath_sin 202 | 203 | !=============================================================================== 204 | 205 | subroutine shr_vmath_cos(X, Y, n) 206 | 207 | !----- arguments --- 208 | integer(SHR_KIND_IN),intent(in) :: n ! vector length 209 | real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument 210 | real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument 211 | 212 | !------------------------------------------------------------------------------- 213 | ! PURPOSE: cos for vector arguments, optimized on different platforms 214 | !------------------------------------------------------------------------------- 215 | 216 | #ifndef NO_SHR_VMATH 217 | #if (defined AIX) 218 | call vcos(Y, X, n) 219 | return 220 | #endif 221 | #if (defined CPRINTEL) 222 | call vdcos(n, X, Y) 223 | return 224 | #endif 225 | #endif 226 | Y = cos(X) 227 | return 228 | 229 | end subroutine shr_vmath_cos 230 | 231 | !=============================================================================== 232 | 233 | end module shr_vmath_mod 234 | -------------------------------------------------------------------------------- /src/shr_pio_mod.F90: -------------------------------------------------------------------------------- 1 | module shr_pio_mod 2 | use pio, only : iosystem_desc_t 3 | use shr_kind_mod, only : shr_kind_cl 4 | use shr_sys_mod, only : shr_sys_abort 5 | 6 | implicit none 7 | private 8 | 9 | public :: shr_pio_getiosys 10 | public :: shr_pio_getiotype 11 | public :: shr_pio_getioroot 12 | public :: shr_pio_getioformat 13 | public :: shr_pio_getrearranger 14 | 15 | interface shr_pio_getiotype 16 | module procedure shr_pio_getiotype_fromid, shr_pio_getiotype_fromname 17 | end interface shr_pio_getiotype 18 | interface shr_pio_getioformat 19 | module procedure shr_pio_getioformat_fromid, shr_pio_getioformat_fromname 20 | end interface shr_pio_getioformat 21 | interface shr_pio_getiosys 22 | module procedure shr_pio_getiosys_fromid, shr_pio_getiosys_fromname 23 | end interface shr_pio_getiosys 24 | interface shr_pio_getioroot 25 | module procedure shr_pio_getioroot_fromid, shr_pio_getioroot_fromname 26 | end interface shr_pio_getioroot 27 | interface shr_pio_getindex 28 | module procedure shr_pio_getindex_fromid, shr_pio_getindex_fromname 29 | end interface shr_pio_getindex 30 | interface shr_pio_getrearranger 31 | module procedure shr_pio_getrearranger_fromid, shr_pio_getrearranger_fromname 32 | end interface shr_pio_getrearranger 33 | 34 | type pio_comp_t 35 | integer :: compid 36 | integer :: pio_root 37 | integer :: pio_stride 38 | integer :: pio_numiotasks 39 | integer :: pio_iotype 40 | integer :: pio_rearranger 41 | integer :: pio_netcdf_ioformat 42 | logical :: pio_async_interface 43 | end type pio_comp_t 44 | 45 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 46 | ! The following variables are public just for the sake of the driver's driver_pio_mod; 47 | ! these NEED to be set by that module. 48 | ! 49 | ! No other subroutines should access these directly! Any other access should go 50 | ! through the above accessor routines. 51 | character(len=16), allocatable, public :: io_compname(:) 52 | type(pio_comp_t), allocatable, public :: pio_comp_settings(:) 53 | type(iosystem_desc_t), allocatable, target, public :: iosystems(:) 54 | integer, allocatable, public :: io_compid(:) 55 | 56 | ! Similarly, this function is public just for the sake of the driver's driver_pio_mod; 57 | ! it should not be used elsewhere. 58 | public :: shr_pio_getindex 59 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 60 | 61 | contains 62 | 63 | function shr_pio_getiotype_fromid(compid) result(io_type) 64 | integer, intent(in) :: compid 65 | integer :: io_type 66 | 67 | io_type = pio_comp_settings(shr_pio_getindex(compid))%pio_iotype 68 | 69 | end function shr_pio_getiotype_fromid 70 | 71 | function shr_pio_getiotype_fromname(component) result(io_type) 72 | ! 'component' must be equal to some element of io_compname(:) 73 | ! (but it is case-insensitive) 74 | character(len=*), intent(in) :: component 75 | integer :: io_type 76 | 77 | io_type = pio_comp_settings(shr_pio_getindex(component))%pio_iotype 78 | 79 | end function shr_pio_getiotype_fromname 80 | 81 | function shr_pio_getrearranger_fromid(compid) result(io_type) 82 | integer, intent(in) :: compid 83 | integer :: io_type 84 | 85 | io_type = pio_comp_settings(shr_pio_getindex(compid))%pio_rearranger 86 | 87 | end function shr_pio_getrearranger_fromid 88 | 89 | function shr_pio_getrearranger_fromname(component) result(io_type) 90 | ! 'component' must be equal to some element of io_compname(:) 91 | ! (but it is case-insensitive) 92 | character(len=*), intent(in) :: component 93 | integer :: io_type 94 | 95 | io_type = pio_comp_settings(shr_pio_getindex(component))%pio_rearranger 96 | 97 | end function shr_pio_getrearranger_fromname 98 | 99 | function shr_pio_getioformat_fromid(compid) result(io_format) 100 | integer, intent(in) :: compid 101 | integer :: io_format 102 | 103 | io_format = pio_comp_settings(shr_pio_getindex(compid))%pio_netcdf_ioformat 104 | 105 | end function shr_pio_getioformat_fromid 106 | 107 | function shr_pio_getioformat_fromname(component) result(io_format) 108 | ! 'component' must be equal to some element of io_compname(:) 109 | ! (but it is case-insensitive) 110 | character(len=*), intent(in) :: component 111 | integer :: io_format 112 | 113 | io_format = pio_comp_settings(shr_pio_getindex(component))%pio_netcdf_ioformat 114 | 115 | end function shr_pio_getioformat_fromname 116 | 117 | function shr_pio_getioroot_fromid(compid) result(io_root) 118 | ! 'component' must be equal to some element of io_compname(:) 119 | ! (but it is case-insensitive) 120 | integer, intent(in) :: compid 121 | integer :: io_root 122 | 123 | io_root = pio_comp_settings(shr_pio_getindex(compid))%pio_root 124 | 125 | end function shr_pio_getioroot_fromid 126 | 127 | function shr_pio_getioroot_fromname(component) result(io_root) 128 | ! 'component' must be equal to some element of io_compname(:) 129 | ! (but it is case-insensitive) 130 | character(len=*), intent(in) :: component 131 | integer :: io_root 132 | 133 | io_root = pio_comp_settings(shr_pio_getindex(component))%pio_root 134 | 135 | end function shr_pio_getioroot_fromname 136 | 137 | 138 | !! Given a component name, return the index of that component. 139 | !! This is the index into io_compid, io_compname, comp_pio_iotype, etc. 140 | !! If the given component is not found, return -1 141 | integer function shr_pio_getindex_fromid(compid) result(index) 142 | implicit none 143 | integer, intent(in) :: compid 144 | integer :: i 145 | character(len=shr_kind_cl) :: msg 146 | 147 | index = -1 148 | do i=1, size(io_compid) 149 | if(io_compid(i)==compid) then 150 | index = i 151 | exit 152 | end if 153 | end do 154 | 155 | if(index<0) then 156 | write(msg, *) 'shr_pio_getindex :: compid=',compid,' out of allowed range: ',io_compid 157 | call shr_sys_abort(msg) 158 | end if 159 | end function shr_pio_getindex_fromid 160 | 161 | integer function shr_pio_getindex_fromname(component) result(index) 162 | use shr_string_mod, only : shr_string_toupper 163 | 164 | implicit none 165 | 166 | ! 'component' must be equal to some element of io_compname(:) 167 | ! (but it is case-insensitive) 168 | character(len=*), intent(in) :: component 169 | 170 | character(len=len(component)) :: component_ucase 171 | integer :: i 172 | 173 | ! convert component name to upper case in order to match case in io_compname 174 | component_ucase = shr_string_toUpper(component) 175 | 176 | index = -1 ! flag for not found 177 | do i=1,size(io_compname) 178 | if (trim(component_ucase) == trim(io_compname(i))) then 179 | index = i 180 | exit 181 | end if 182 | end do 183 | if(index<0) then 184 | call shr_sys_abort(' shr_pio_getindex:: compid out of allowed range') 185 | end if 186 | end function shr_pio_getindex_fromname 187 | 188 | function shr_pio_getiosys_fromid(compid) result(iosystem) 189 | ! 'component' must be equal to some element of io_compname(:) 190 | ! (but it is case-insensitive) 191 | integer, intent(in) :: compid 192 | type(iosystem_desc_t), pointer :: iosystem 193 | 194 | iosystem => iosystems(shr_pio_getindex(compid)) 195 | 196 | end function shr_pio_getiosys_fromid 197 | 198 | function shr_pio_getiosys_fromname(component) result(iosystem) 199 | ! 'component' must be equal to some element of io_compname(:) 200 | ! (but it is case-insensitive) 201 | character(len=*), intent(in) :: component 202 | type(iosystem_desc_t), pointer :: iosystem 203 | 204 | iosystem => iosystems(shr_pio_getindex(component)) 205 | 206 | end function shr_pio_getiosys_fromname 207 | 208 | end module shr_pio_mod 209 | -------------------------------------------------------------------------------- /test/unit/shr_infnan_test/test_infnan.F90: -------------------------------------------------------------------------------- 1 | program test_infnan 2 | 3 | ! 4 | ! This is a test for the shr_infnan_mod module. It was created using the 5 | ! pre-CTest system, with minimal changes to keep it working. So it may not 6 | ! be a great example of a CTest test now. 7 | ! 8 | 9 | use shr_kind_mod, only: r8 => shr_kind_r8 10 | use shr_kind_mod, only: r4 => shr_kind_r4 11 | use shr_kind_mod, only: i8 => shr_kind_i8 12 | use shr_kind_mod, only: i4 => shr_kind_i4 13 | use, intrinsic :: ieee_exceptions, only : ieee_status_type, ieee_get_status, ieee_set_status 14 | use, intrinsic :: ieee_exceptions, only : ieee_set_halting_mode 15 | use, intrinsic :: ieee_exceptions, only : ieee_invalid, ieee_divide_by_zero 16 | use shr_infnan_mod 17 | 18 | implicit none 19 | 20 | type(ieee_status_type) :: status_value 21 | real(r8) :: x, zero 22 | real(r4) :: y 23 | real(r8) :: r8array(100), r82Darray(10,10), r83Darray(4,4,4) 24 | real(r8) :: r84Darray(3,3,3,3), r85Darray(2,2,2,2,2) 25 | real(r8) :: inf 26 | real(r8) :: nan 27 | real(r8) :: nans 28 | real(r4) :: spnan 29 | real(r4) :: spnans 30 | integer(i8), parameter :: dpinfpat = int(O'0777600000000000000000',i8) 31 | integer(i8), parameter :: dpnanpat = int(O'0777700000000000000000',i8) 32 | integer(i8), parameter :: dpnanspat = int(O'0777610000000000000000',i8) 33 | integer(i4), parameter :: spnanpat = int(Z'7FC00000',i4) 34 | integer(i4), parameter :: spnanspat = int(Z'7FC10000',i4) 35 | intrinsic :: count 36 | 37 | ! Get initial ieee status so we can restore it later 38 | call ieee_get_status(status_value) 39 | 40 | ! Need to turn off ieee_invalid checks for some of these tests to pass 41 | call ieee_set_halting_mode([ieee_invalid, ieee_divide_by_zero], .false.) 42 | 43 | inf = transfer(dpinfpat,inf) 44 | nan = transfer(dpnanpat,nan) 45 | nans = transfer(dpnanspat,nans) 46 | spnan = transfer( spnanpat,spnan) 47 | spnans = transfer( spnanspat,spnans) 48 | 49 | x = 0.0 50 | zero = 0.0 51 | 52 | call assert( shr_infnan_isnan( nan ), "Test that value set to nan is nan" ) 53 | call assert( shr_infnan_isnan( nans ), "Test that value set to nans is nan" ) 54 | call assert( shr_infnan_isnan( spnan ), "Test that value set to sp nan is nan" ) 55 | call assert( shr_infnan_isnan( spnans ), "Test that value set to sp nans is nan" ) 56 | call assert( .not. shr_infnan_isnan( 1.0_r8 ), "Test that value set to one is NOT nan" ) 57 | call assert( .not. shr_infnan_isnan( 1.0_r4 ), "Test that value set to SP one is NOT nan" ) 58 | call assert( .not. shr_infnan_isnan( huge(x) ), "Test that value set to huge is NOT nan" ) 59 | x = 1.0/zero 60 | call assert( .not. shr_infnan_isnan( x ), "Test that 1/0 is NOT nan" ) 61 | x = -1.0/zero 62 | call assert( .not. shr_infnan_isnan( x ), "Test that -1/0 is NOT nan" ) 63 | 64 | r8array(:) = 1.0d00 65 | r8array(10) = nan 66 | r8array(15) = nan 67 | r82Darray(:,:) = 1.0d00 68 | r82Darray(5,5) = nan 69 | r82Darray(10,7) = nan 70 | r82Darray(7,9) = nan 71 | r83Darray(:,:,:) = 1.0d00 72 | r83Darray(4,2,2) = nan 73 | r83Darray(3,1,2) = nan 74 | r83Darray(1,1,1) = nan 75 | r83Darray(1,1,4) = nan 76 | r84Darray(:,:,:,:) = 1.0d00 77 | r84Darray(3,2,2,1) = nan 78 | r84Darray(3,1,2,1) = nan 79 | r84Darray(1,1,1,1) = nan 80 | r84Darray(1,1,3,1) = nan 81 | r84Darray(1,2,3,1) = nan 82 | r85Darray(:,:,:,:,:) = 1.0d00 83 | r85Darray(1,2,2,1,1) = nan 84 | r85Darray(1,1,2,1,2) = nan 85 | r85Darray(1,1,1,2,1) = nan 86 | r85Darray(1,2,2,2,1) = nan 87 | r85Darray(1,2,1,1,2) = nan 88 | r85Darray(1,1,1,1,1) = nan 89 | call assert( any(shr_infnan_isnan( r8array )), "Test that array with 2 nans is nan" ) 90 | call assert( count(shr_infnan_isnan( r8array )) == 2, "Test that there are 2 nans in that array" ) 91 | call assert( any(shr_infnan_isnan( r82Darray )), "Test that 2D array with 3 nans is nan" ) 92 | call assert( count(shr_infnan_isnan( r82Darray )) == 3, "Test that there are 3 nans in that array" ) 93 | call assert( any(shr_infnan_isnan( r83Darray )), "Test that 3D array with 4 nans is nan" ) 94 | call assert( count(shr_infnan_isnan( r83Darray )) == 4, "Test that there are 4 nans in that array" ) 95 | call assert( any(shr_infnan_isnan( r84Darray )), "Test that 4D array with 5 nans is nan" ) 96 | call assert( count(shr_infnan_isnan( r84Darray )) == 5, "Test that there are 5 nans in that array" ) 97 | call assert( any(shr_infnan_isnan( r85Darray )), "Test that 5D array with 6 nans is nan" ) 98 | call assert( count(shr_infnan_isnan( r85Darray )) == 6, "Test that there are 6 nans in that array" ) 99 | call assert( shr_infnan_isposinf( inf ), "Test that value set to inf is inf" ) 100 | call assert( .not. shr_infnan_isposinf( 1.0_r8 ), "Test that value set to one is NOT inf" ) 101 | call assert( .not. shr_infnan_isposinf( 1.0_r4 ), "Test that value set to SP one is NOT inf" ) 102 | call assert( shr_infnan_isneginf( -inf ), "Test that value set to -inf is -inf" ) 103 | call assert( .not. shr_infnan_isneginf( 1.0_r8 ), "Test that value set to one is NOT -inf" ) 104 | call assert( .not. shr_infnan_isneginf( 1.0_r4 ), "Test that value set to SP one is NOT -inf" ) 105 | x = 1.0/zero 106 | call assert( shr_infnan_isposinf( x ), "Test that 1/0 is inf" ) 107 | x = -1.0/zero 108 | call assert( shr_infnan_isneginf( x ), "Test that -1/0 is -inf" ) 109 | 110 | x = -1.0 111 | call assert( shr_infnan_isnan( sqrt(x) ), "Test that sqrt-1 is nan" ) 112 | call assert( shr_infnan_isnan( log(x) ), "Test that log-1 is nan" ) 113 | 114 | x = shr_infnan_nan 115 | call assert( shr_infnan_isnan( x ), "Test that shr_infnan_nan sets r8 to nan" ) 116 | y = shr_infnan_nan 117 | call assert( shr_infnan_isnan( y ), "Test that shr_infnan_nan sets r4 to nan" ) 118 | 119 | x = shr_infnan_inf 120 | call assert( shr_infnan_isinf( x ), "Test that shr_infnan_inf sets r8 to inf" ) 121 | y = shr_infnan_inf 122 | call assert( shr_infnan_isinf( y ), "Test that shr_infnan_inf sets r4 to inf" ) 123 | 124 | x = shr_infnan_posinf 125 | call assert( shr_infnan_isposinf( x ), "Test that shr_infnan_posinf sets r8 to +inf" ) 126 | y = shr_infnan_posinf 127 | call assert( shr_infnan_isposinf( y ), "Test that shr_infnan_posinf sets r4 to +inf" ) 128 | 129 | x = shr_infnan_neginf 130 | call assert( shr_infnan_isneginf( x ), "Test that shr_infnan_neginf sets r8 to -inf" ) 131 | y = shr_infnan_neginf 132 | call assert( shr_infnan_isneginf( y ), "Test that shr_infnan_neginf sets r4 to -inf" ) 133 | 134 | x = shr_infnan_to_r8(shr_infnan_qnan) 135 | call assert( shr_infnan_isnan( x ), "Test that shr_infnan_to_r8(shr_infnan_qnan) sets r8 to nan" ) 136 | y = shr_infnan_to_r4(shr_infnan_qnan) 137 | call assert( shr_infnan_isnan( y ), "Test that shr_infnan_to_r4(shr_infnan_qnan) sets r4 to nan" ) 138 | 139 | x = shr_infnan_to_r8(shr_infnan_snan) 140 | call assert( shr_infnan_isnan( x ), "Test that shr_infnan_to_r8(shr_infnan_snan) sets r8 to nan" ) 141 | y = shr_infnan_to_r4(shr_infnan_snan) 142 | call assert( shr_infnan_isnan( y ), "Test that shr_infnan_to_r4(shr_infnan_snan) sets r4 to nan" ) 143 | 144 | x = shr_infnan_to_r8(shr_infnan_posinf) 145 | call assert( shr_infnan_isposinf( x ), "Test that shr_infnan_to_r8(shr_infnan_posinf) sets r8 to +inf" ) 146 | y = shr_infnan_to_r4(shr_infnan_posinf) 147 | call assert( shr_infnan_isposinf( y ), "Test that shr_infnan_to_r4(shr_infnan_posinf) sets r4 to +inf" ) 148 | 149 | x = shr_infnan_to_r8(shr_infnan_neginf) 150 | call assert( shr_infnan_isneginf( x ), "Test that shr_infnan_to_r8(shr_infnan_neginf) sets r8 to -inf" ) 151 | y = shr_infnan_to_r4(shr_infnan_neginf) 152 | call assert( shr_infnan_isneginf( y ), "Test that shr_infnan_to_r4(shr_infnan_neginf) sets r4 to -inf" ) 153 | 154 | ! Restore original status 155 | ! 156 | ! At least with gfortran, this restoration prevents floating point exceptions from being 157 | ! raised at the end of the run. Alternatively, we could probably set various flags to 158 | ! .false., using ieee_set_flag. 159 | call ieee_set_status(status_value) 160 | 161 | contains 162 | 163 | subroutine assert(val, msg) 164 | logical, intent(in) :: val 165 | character(len=*), intent(in) :: msg 166 | 167 | if (.not. val) then 168 | print *, msg 169 | stop 1 170 | end if 171 | 172 | end subroutine assert 173 | 174 | end program test_infnan 175 | -------------------------------------------------------------------------------- /test/unit/shr_wv_sat_test/test_wv_sat.pf: -------------------------------------------------------------------------------- 1 | module test_wv_sat 2 | 3 | use funit 4 | 5 | use shr_kind_mod, only: r8 => shr_kind_r8 6 | use shr_const_mod, only: & 7 | tmelt => shr_const_tkfrz, & 8 | h2otrip => shr_const_tktrip, & 9 | mwwv => shr_const_mwwv, & 10 | mwdair => shr_const_mwdair 11 | use shr_wv_sat_mod 12 | 13 | implicit none 14 | public 15 | 16 | real(r8), parameter :: t_transition = 20._r8 17 | real(r8), parameter :: epsilo = mwwv/mwdair 18 | 19 | contains 20 | 21 | @Before 22 | subroutine setUp() 23 | 24 | character(len=128) :: errstring 25 | 26 | call shr_wv_sat_init(tmelt, h2otrip, t_transition, epsilo, errstring) 27 | 28 | if (errstring /= "") then 29 | call throw("Error from shr_wv_sat_init: "//trim(errstring)) 30 | end if 31 | 32 | end subroutine setUp 33 | 34 | @After 35 | subroutine tearDown() 36 | call shr_wv_sat_final() 37 | end subroutine tearDown 38 | 39 | @Test 40 | subroutine invalid_name_produces_invalid_index() 41 | 42 | integer :: idx 43 | 44 | idx = shr_wv_sat_get_scheme_idx("NotARealSaturationSchemeName") 45 | @assertTrue(.not. shr_wv_sat_valid_idx(idx)) 46 | 47 | end subroutine invalid_name_produces_invalid_index 48 | 49 | @Test 50 | subroutine reject_out_of_bounds_transition 51 | 52 | character(len=128) :: errstring 53 | 54 | ! Negative transition ranges are meaningless. 55 | call shr_wv_sat_init(tmelt, h2otrip, -1._r8, epsilo, errstring) 56 | @assertTrue(errstring /= "") 57 | 58 | ! A transition range of 0 is OK. 59 | call shr_wv_sat_init(tmelt, h2otrip, 0._r8, epsilo, errstring) 60 | @assertTrue(errstring == "") 61 | 62 | end subroutine reject_out_of_bounds_transition 63 | 64 | @Test 65 | subroutine qsat_not_greater_than_one() 66 | 67 | ! Even if the SVP is greater the current pressure, the saturation specific 68 | ! humidity returned should be capped at 1. 69 | @assertEqual(1.0_r8, shr_wv_sat_svp_to_qsat(1.0_r8, 0.5_r8)) 70 | @assertEqual(1.0_r8, shr_wv_sat_svp_to_qsat(2, [1.0_r8, 2.0_r8], [0.5_r8, 0.5_r8])) 71 | 72 | end subroutine qsat_not_greater_than_one 73 | 74 | @Test 75 | subroutine qmmr_not_greater_than_epsilon() 76 | 77 | integer, parameter :: n = 3 78 | real(r8), parameter :: es(n) = [0.51_r8, 1.0_r8, 1.5_r8] 79 | real(r8), parameter :: p(n) = [1.0_r8, 1.0_r8, 1.0_r8] 80 | 81 | integer :: i 82 | 83 | ! As SVP becomes close to the actual pressure, the mass mixing ratio goes to 84 | ! infinity, so check that we actually cap it at epsilon once the SVP is more 85 | ! than half the total pressure. 86 | do i = 1, 3 87 | @assertEqual(epsilo, shr_wv_sat_svp_to_qmmr(es(i), p(i))) 88 | end do 89 | @assertEqual(epsilo, shr_wv_sat_svp_to_qmmr(n, es, p)) 90 | 91 | end subroutine qmmr_not_greater_than_epsilon 92 | 93 | @Test 94 | subroutine esat_not_greater_than_p() 95 | 96 | real(r8) :: es, qs 97 | real(r8) :: es_vec(1), qs_vec(1) 98 | 99 | ! For the combined routine, we don't allow the SVP to exceed the current 100 | ! pressure. Tested here by simply providing an extremely low pressure. 101 | 102 | ! This is a guard against schemes that "blindly" attempt to reach saturation 103 | ! by evaporating cloud water, no matter what the conditions. At very low 104 | ! pressures this is impossible, so we return a limited value to prevent 105 | ! numerical issues. 106 | 107 | call shr_wv_sat_qsat_liquid(280._r8, 1.e-30_r8, es, qs) 108 | @assertEqual(1.e-30_r8, es) 109 | 110 | call shr_wv_sat_qsat_liquid(1, [280._r8], [1.e-30_r8], es_vec, qs_vec) 111 | @assertEqual([1.e-30_r8], es_vec) 112 | 113 | call shr_wv_sat_qsat_ice(260._r8, 1.e-30_r8, es, qs) 114 | @assertEqual(1.e-30_r8, es) 115 | 116 | call shr_wv_sat_qsat_ice(1, [260._r8], [1.e-30_r8], es_vec, qs_vec) 117 | @assertEqual([1.e-30_r8], es_vec) 118 | 119 | call shr_wv_sat_qsat_mixed(270._r8, 1.e-30_r8, es, qs) 120 | @assertEqual(1.e-30_r8, es) 121 | 122 | call shr_wv_sat_qsat_mixed(1, [270._r8], [1.e-30_r8], es_vec, qs_vec) 123 | @assertEqual([1.e-30_r8], es_vec) 124 | 125 | end subroutine esat_not_greater_than_p 126 | 127 | @Test 128 | subroutine liquid_vapor_table_is_used() 129 | type(ShrWVSatTableSpec) :: liquid_table_spec 130 | 131 | real(r8) :: non_table_value 132 | real(r8) :: table_value 133 | 134 | non_table_value = shr_wv_sat_svp_liquid(tmelt+7.5_r8) 135 | 136 | liquid_table_spec = ShrWVSatTableSpec(151, tmelt-50._r8, 1._r8) 137 | call shr_wv_sat_make_tables(liquid_spec_in=liquid_table_spec) 138 | 139 | table_value = shr_wv_sat_svp_liquid(tmelt+7.5_r8) 140 | 141 | ! We can't really see directly whether the table is used, but we can pick a 142 | ! value that requires interpolation and look for the difference. 143 | @assertFalse(non_table_value == table_value) 144 | 145 | end subroutine liquid_vapor_table_is_used 146 | 147 | @Test 148 | subroutine liquid_vapor_table_not_extrapolated() 149 | type(ShrWVSatTableSpec) :: liquid_table_spec 150 | 151 | real(r8) :: non_table_low_value, non_table_high_value 152 | real(r8) :: table_low_value, table_high_value 153 | 154 | non_table_low_value = shr_wv_sat_svp_liquid(tmelt-50.5_r8) 155 | non_table_high_value = shr_wv_sat_svp_liquid(tmelt+150.5_r8) 156 | 157 | liquid_table_spec = ShrWVSatTableSpec(151, tmelt-50._r8, 1._r8) 158 | call shr_wv_sat_make_tables(liquid_spec_in=liquid_table_spec) 159 | 160 | table_low_value = shr_wv_sat_svp_liquid(tmelt-50.5_r8) 161 | table_high_value = shr_wv_sat_svp_liquid(tmelt+150.5_r8) 162 | 163 | ! Beyond the table boundaries, the lookup table should not be used, and so we 164 | ! should get the same answer as before specifying any tables. 165 | @assertEqual(non_table_low_value, table_low_value) 166 | @assertEqual(non_table_high_value, table_high_value) 167 | 168 | end subroutine liquid_vapor_table_not_extrapolated 169 | 170 | @Test 171 | subroutine ice_vapor_table_is_used() 172 | type(ShrWVSatTableSpec) :: ice_table_spec 173 | 174 | real(r8) :: non_table_value 175 | real(r8) :: table_value 176 | 177 | non_table_value = shr_wv_sat_svp_ice(tmelt-7.5_r8) 178 | 179 | ice_table_spec = ShrWVSatTableSpec(106, tmelt-100._r8, 1._r8) 180 | call shr_wv_sat_make_tables(ice_spec_in=ice_table_spec) 181 | 182 | table_value = shr_wv_sat_svp_ice(tmelt-7.5_r8) 183 | 184 | ! We can't really see directly whether the table is used, but we can pick a 185 | ! value that requires interpolation and look for the difference. 186 | @assertFalse(non_table_value == table_value) 187 | 188 | end subroutine ice_vapor_table_is_used 189 | 190 | @Test 191 | subroutine ice_vapor_table_not_extrapolated() 192 | type(ShrWVSatTableSpec) :: ice_table_spec 193 | 194 | real(r8) :: non_table_low_value, non_table_high_value 195 | real(r8) :: table_low_value, table_high_value 196 | 197 | non_table_low_value = shr_wv_sat_svp_ice(tmelt-100.5_r8) 198 | non_table_high_value = shr_wv_sat_svp_ice(tmelt+5.5_r8) 199 | 200 | ice_table_spec = ShrWVSatTableSpec(106, tmelt-100._r8, 1._r8) 201 | call shr_wv_sat_make_tables(ice_spec_in=ice_table_spec) 202 | 203 | table_low_value = shr_wv_sat_svp_ice(tmelt-100.5_r8) 204 | table_high_value = shr_wv_sat_svp_ice(tmelt+5.5_r8) 205 | 206 | ! Beyond the table boundaries, the lookup table should not be used, and so we 207 | ! should get the same answer as before specifying any tables. 208 | @assertEqual(non_table_low_value, table_low_value) 209 | @assertEqual(non_table_high_value, table_high_value) 210 | 211 | end subroutine ice_vapor_table_not_extrapolated 212 | 213 | @Test 214 | subroutine mixed_vapor_table_is_used() 215 | type(ShrWVSatTableSpec) :: mixed_table_spec 216 | 217 | real(r8) :: non_table_value 218 | real(r8) :: table_value 219 | 220 | non_table_value = shr_wv_sat_svp_mixed(tmelt-7.5_r8) 221 | 222 | mixed_table_spec = ShrWVSatTableSpec(201, tmelt-100._r8, 1._r8) 223 | call shr_wv_sat_make_tables(mixed_spec_in=mixed_table_spec) 224 | 225 | table_value = shr_wv_sat_svp_mixed(tmelt-7.5_r8) 226 | 227 | ! We can't really see directly whether the table is used, but we can pick a 228 | ! value that requires interpolation and look for the difference. 229 | @assertFalse(non_table_value == table_value) 230 | 231 | end subroutine mixed_vapor_table_is_used 232 | 233 | @Test 234 | subroutine mixed_vapor_table_not_extrapolated() 235 | type(ShrWVSatTableSpec) :: mixed_table_spec 236 | 237 | real(r8) :: non_table_low_value, non_table_high_value 238 | real(r8) :: table_low_value, table_high_value 239 | 240 | non_table_low_value = shr_wv_sat_svp_mixed(tmelt-100.5_r8) 241 | non_table_high_value = shr_wv_sat_svp_mixed(tmelt+100.5_r8) 242 | 243 | mixed_table_spec = ShrWVSatTableSpec(201, tmelt-100._r8, 1._r8) 244 | call shr_wv_sat_make_tables(mixed_spec_in=mixed_table_spec) 245 | 246 | table_low_value = shr_wv_sat_svp_mixed(tmelt-100.5_r8) 247 | table_high_value = shr_wv_sat_svp_mixed(tmelt+100.5_r8) 248 | 249 | ! Beyond the table boundaries, the lookup table should not be used, and so we 250 | ! should get the same answer as before specifying any tables. 251 | @assertEqual(non_table_low_value, table_low_value) 252 | @assertEqual(non_table_high_value, table_high_value) 253 | 254 | end subroutine mixed_vapor_table_not_extrapolated 255 | 256 | end module test_wv_sat 257 | -------------------------------------------------------------------------------- /test/unit/shr_wv_sat_test/test_wv_sat_each_method.pf: -------------------------------------------------------------------------------- 1 | ! This module has a parameterized test list for application to each of the 2 | ! individual methods provided by shr_wv_sat_mod. 3 | module test_wv_sat_each_method 4 | 5 | use funit 6 | 7 | use shr_kind_mod, only: r8 => shr_kind_r8 8 | use shr_const_mod, only: & 9 | tmelt => shr_const_tkfrz, & 10 | h2otrip => shr_const_tktrip, & 11 | mwwv => shr_const_mwwv, & 12 | mwdair => shr_const_mwdair 13 | use shr_wv_sat_mod 14 | 15 | implicit none 16 | public 17 | 18 | real(r8), parameter :: t_transition = 20._r8 19 | 20 | @TestParameter 21 | type, extends(AbstractTestParameter) :: WVSchemeParameters 22 | character(len=32) :: scheme_name 23 | real(r8) :: relative_tol 24 | logical :: make_table 25 | logical :: use_vector 26 | contains 27 | procedure :: toString 28 | end type WVSchemeParameters 29 | 30 | @TestCase(testParameters={getParameters()}, constructor=new_WVSchemeCase) 31 | type, extends(ParameterizedTestCase) :: WVSchemeCase 32 | character(len=32) :: scheme_name 33 | real(r8) :: relative_tol 34 | logical :: make_table 35 | logical :: use_vector 36 | contains 37 | procedure :: setUp 38 | procedure :: tearDown 39 | end type WVSchemeCase 40 | 41 | contains 42 | 43 | ! Simple routines to convert parameters to a test case or a string, 44 | ! respectively. 45 | 46 | function new_WVSchemeCase(params) result(test) 47 | type(WVSchemeParameters), intent(in) :: params 48 | type(WVSchemeCase) :: test 49 | 50 | test%scheme_name = params%scheme_name 51 | test%relative_tol = params%relative_tol 52 | test%make_table = params%make_table 53 | test%use_vector = params%use_vector 54 | 55 | end function new_WVSchemeCase 56 | 57 | function toString(this) result(string) 58 | class(WVSchemeParameters), intent(in) :: this 59 | character(:), allocatable :: string 60 | 61 | character(len=80) :: buffer 62 | 63 | write(buffer,*) "(scheme=",this%scheme_name,",table=",this%make_table, & 64 | ",vec=",this%use_vector,")" 65 | 66 | string = trim(buffer) 67 | 68 | end function toString 69 | 70 | ! setUp/tearDown to init the module and to actually set the current scheme. 71 | subroutine setUp(this) 72 | 73 | class(WVSchemeCase), intent(inout) :: this 74 | 75 | real(r8), parameter :: epsilo = mwwv/mwdair 76 | 77 | character(len=128) :: errstring 78 | 79 | type(ShrWVSatTableSpec) :: liquid_table_spec, ice_table_spec, mixed_table_spec 80 | 81 | call shr_wv_sat_init(tmelt, h2otrip, t_transition, epsilo, errstring) 82 | 83 | if (errstring /= "") then 84 | call throw("Error from shr_wv_sat_init: "//trim(errstring)) 85 | end if 86 | 87 | @assertTrue(shr_wv_sat_set_default(this%scheme_name)) 88 | 89 | if (this%make_table) then 90 | liquid_table_spec = ShrWVSatTableSpec(151, tmelt-50._r8, 1._r8) 91 | ice_table_spec = ShrWVSatTableSpec(106, tmelt-100._r8, 1._r8) 92 | mixed_table_spec = ShrWVSatTableSpec(201, tmelt-100._r8, 1._r8) 93 | call shr_wv_sat_make_tables(& 94 | liquid_spec_in=liquid_table_spec, & 95 | ice_spec_in=ice_table_spec, & 96 | mixed_spec_in=mixed_table_spec) 97 | end if 98 | 99 | end subroutine setUp 100 | 101 | subroutine tearDown(this) 102 | 103 | class(WVSchemeCase), intent(inout) :: this 104 | 105 | call shr_wv_sat_final() 106 | 107 | end subroutine tearDown 108 | 109 | ! List of testable schemes. 110 | 111 | function getParameters() result(params) 112 | type(WVSchemeParameters), allocatable :: params(:) 113 | 114 | params = [ & 115 | WVSchemeParameters("GoffGratch", 0.002_r8, .false., .false.), & 116 | WVSchemeParameters("MurphyKoop", 0.001_r8, .false., .false.), & 117 | WVSchemeParameters("Flatau", 0.003_r8, .false., .false.), & 118 | WVSchemeParameters("Bolton", 0.001_r8, .false., .false.), & 119 | WVSchemeParameters("GoffGratch", 0.002_r8, .true., .false.), & 120 | WVSchemeParameters("GoffGratch", 0.002_r8, .false., .true.), & 121 | WVSchemeParameters("GoffGratch", 0.002_r8, .true., .true.) ] 122 | 123 | end function getParameters 124 | 125 | ! Tests for water and ice functions for each scheme. 126 | 127 | @Test 128 | subroutine scheme_has_correct_ice_trip_point(this) 129 | class(WVSchemeCase), intent(inout) :: this 130 | 131 | if (this%use_vector) then 132 | call assertRelativelyEqual([611.7_r8], shr_wv_sat_svp_ice(1, [h2otrip]), & 133 | tolerance=this%relative_tol) 134 | else 135 | call assertRelativelyEqual(611.7_r8, shr_wv_sat_svp_ice(h2otrip), & 136 | tolerance=this%relative_tol) 137 | end if 138 | 139 | end subroutine scheme_has_correct_ice_trip_point 140 | 141 | @Test 142 | subroutine scheme_has_correct_liquid_trip_point(this) 143 | class(WVSchemeCase), intent(inout) :: this 144 | 145 | if (this%use_vector) then 146 | call assertRelativelyEqual([611.7_r8], shr_wv_sat_svp_liquid(1, [h2otrip]), & 147 | tolerance=this%relative_tol) 148 | else 149 | call assertRelativelyEqual(611.7_r8, shr_wv_sat_svp_liquid(h2otrip), & 150 | tolerance=this%relative_tol) 151 | end if 152 | 153 | end subroutine scheme_has_correct_liquid_trip_point 154 | 155 | @Test 156 | subroutine scheme_has_correct_liquid_value(this) 157 | class(WVSchemeCase), intent(inout) :: this 158 | 159 | ! Check a warm value (25 deg C). 160 | if (this%use_vector) then 161 | call assertRelativelyEqual([3169._r8], shr_wv_sat_svp_liquid(1, [tmelt+25._r8]), & 162 | tolerance=this%relative_tol) 163 | else 164 | call assertRelativelyEqual(3169._r8, shr_wv_sat_svp_liquid(tmelt+25._r8), & 165 | tolerance=this%relative_tol) 166 | end if 167 | 168 | end subroutine scheme_has_correct_liquid_value 169 | 170 | @Test 171 | subroutine scheme_has_correct_ice_value(this) 172 | class(WVSchemeCase), intent(inout) :: this 173 | 174 | ! Check a cold value (-50 deg C). 175 | if (this%use_vector) then 176 | call assertRelativelyEqual([3.935], shr_wv_sat_svp_ice(1, [tmelt-50._r8]), & 177 | tolerance=this%relative_tol) 178 | else 179 | call assertRelativelyEqual(3.935, shr_wv_sat_svp_ice(tmelt-50._r8), & 180 | tolerance=this%relative_tol) 181 | end if 182 | 183 | end subroutine scheme_has_correct_ice_value 184 | 185 | ! Tests for the combined water-ice function with transition range. 186 | ! Technically, these don't have to be done for each scheme, but it doesn't hurt 187 | ! to run them many times, since the tests are very quick. 188 | 189 | @Test 190 | subroutine scheme_has_correct_mixed_trip_point(this) 191 | class(WVSchemeCase), intent(inout) :: this 192 | 193 | if (this%use_vector) then 194 | call assertRelativelyEqual([611.7_r8], shr_wv_sat_svp_mixed(1, [h2otrip]), & 195 | tolerance=this%relative_tol) 196 | else 197 | call assertRelativelyEqual(611.7_r8, shr_wv_sat_svp_mixed(h2otrip), & 198 | tolerance=this%relative_tol) 199 | end if 200 | 201 | end subroutine scheme_has_correct_mixed_trip_point 202 | 203 | @Test 204 | subroutine scheme_has_correct_mixed_as_ice(this) 205 | class(WVSchemeCase), intent(inout) :: this 206 | 207 | real(r8) :: t_all_ice = tmelt - t_transition - 1._r8 208 | 209 | real(r8) :: ice_svp 210 | 211 | ice_svp = shr_wv_sat_svp_ice(t_all_ice) 212 | 213 | ! Below the transition range, trans and ice should be equal. 214 | if (this%use_vector) then 215 | call assertRelativelyEqual([ice_svp], shr_wv_sat_svp_mixed(1, [t_all_ice]), & 216 | tolerance=this%relative_tol) 217 | else 218 | call assertRelativelyEqual(ice_svp, shr_wv_sat_svp_mixed(t_all_ice), & 219 | tolerance=this%relative_tol) 220 | end if 221 | 222 | end subroutine scheme_has_correct_mixed_as_ice 223 | 224 | @Test 225 | subroutine scheme_has_correct_mixed_as_liquid(this) 226 | class(WVSchemeCase), intent(inout) :: this 227 | 228 | real(r8) :: t_all_liquid = tmelt + 1._r8 229 | 230 | real(r8) :: liquid_svp 231 | 232 | liquid_svp = shr_wv_sat_svp_liquid(t_all_liquid) 233 | 234 | ! Above the transition range, trans and water should be equal. 235 | if (this%use_vector) then 236 | call assertRelativelyEqual([liquid_svp], shr_wv_sat_svp_mixed(1, [t_all_liquid]), & 237 | tolerance=this%relative_tol) 238 | else 239 | call assertRelativelyEqual(liquid_svp, shr_wv_sat_svp_mixed(t_all_liquid), & 240 | tolerance=this%relative_tol) 241 | end if 242 | 243 | end subroutine scheme_has_correct_mixed_as_liquid 244 | 245 | @Test 246 | subroutine scheme_has_correct_mixed_in_range(this) 247 | class(WVSchemeCase), intent(inout) :: this 248 | 249 | ! Temperature at which we are halfway through the transition range. 250 | real(r8), parameter :: t_half = tmelt - 0.5*t_transition 251 | 252 | real(r8) :: ice_svp, liquid_svp 253 | 254 | ice_svp = shr_wv_sat_svp_ice(t_half) 255 | liquid_svp = shr_wv_sat_svp_liquid(t_half) 256 | 257 | ! Check that transition SVP is the average of the ice and water SVPs. 258 | if (this%use_vector) then 259 | call assertRelativelyEqual([0.5_r8 * (ice_svp+liquid_svp)], & 260 | shr_wv_sat_svp_mixed(1, [t_half]), & 261 | tolerance=this%relative_tol) 262 | else 263 | call assertRelativelyEqual(0.5_r8 * (ice_svp+liquid_svp), & 264 | shr_wv_sat_svp_mixed(t_half), & 265 | tolerance=this%relative_tol) 266 | end if 267 | 268 | end subroutine scheme_has_correct_mixed_in_range 269 | 270 | end module test_wv_sat_each_method 271 | --------------------------------------------------------------------------------