From 112cc2b8fd3ef067c8f5293b2b2c24e962b2e312 Mon Sep 17 00:00:00 2001 From: Jesse Nusbaumer Date: Tue, 15 Oct 2024 09:09:20 -0600 Subject: [PATCH] Implement re-organized CCPP physics external (#306) Originator(s): nusbaume Summary (include the keyword ['closes', 'fixes', 'resolves'] and issue number): This PR bring in a new atmospheric_physics version with a re-organized directory structure. The way this impacts CAM-SIMA is that now when a physics suite is listed it will first look in the case's SourceMods first, `ncar_ccpp/suites` second, and `ncar_ccpp/test/test_suites` third, after which it will error if it hasn't found the Suite Definition File (SDF). The CAM-SIMA build system also now looks in `ncar_ccpp/schemes` for any CCPP physics source code and metadata files. Fixes #305 The associated atmospehric_physics PR can be found here: ESCOMP/atmospheric_physics#126 Describe any changes made to build system: The CAM-SIMA configuration routines will now look under `suites` or `test_suites` for SDFs, with the `suites` entries taking precedence (unless the case has SourceMods, in which those always take precedence). All of the relevant source code and metadata files for atmospheric physics must also now be present under the `schemes` directory in the atmospheric_physics repo. Describe any changes made to the namelist: N/A List any changes to the defaults for the input datasets (e.g. boundary datasets): N/A List all files eliminated and why: Remove unused "test/include" directory: D test/include/Makefile D test/include/cam_abortutils.F90 D test/include/cam_logfile.F90 D test/include/ccpp_kinds.F90 D test/include/shr_infnan_mod.F90 D test/include/shr_kind_mod.F90 D test/include/spmd_utils.F90 List all files added and what they do: N/A List all existing files that have been modified, and describe the changes: (Helpful git command: git diff --name-status development...) Update atmospheric_physics external: M .gitmodules M src/physics/ncar_ccpp Update CCPP SDF, source, and metadata file search locations and precedence: M cime_config/cam_autogen.py Add FTJ16 compset and cleanup simple physics configuration options: M cime_config/config_component.xml If there are new failures (compare to the existing-test-failures.txt file), have them OK'd by the gatekeeper, note them here, and add them to the file. If there are baseline differences, include the test and the reason for the diff. What is the nature of the change? Roundoff? derecho/intel/aux_sima: ALL PASS derecho/gnu/aux_sima: ALL PASS CAM-SIMA date used for the baseline comparison tests if different than latest: --- .gitmodules | 2 +- cime_config/cam_autogen.py | 21 +- cime_config/config_component.xml | 10 +- src/physics/ncar_ccpp | 2 +- test/include/Makefile | 14 - test/include/cam_abortutils.F90 | 17 - test/include/cam_logfile.F90 | 96 -- test/include/ccpp_kinds.F90 | 10 - test/include/shr_infnan_mod.F90 | 1907 ------------------------------ test/include/shr_kind_mod.F90 | 19 - test/include/spmd_utils.F90 | 11 - 11 files changed, 21 insertions(+), 2088 deletions(-) delete mode 100644 test/include/Makefile delete mode 100644 test/include/cam_abortutils.F90 delete mode 100644 test/include/cam_logfile.F90 delete mode 100644 test/include/ccpp_kinds.F90 delete mode 100644 test/include/shr_infnan_mod.F90 delete mode 100644 test/include/shr_kind_mod.F90 delete mode 100644 test/include/spmd_utils.F90 diff --git a/.gitmodules b/.gitmodules index 949b88cd..1fc97042 100644 --- a/.gitmodules +++ b/.gitmodules @@ -14,7 +14,7 @@ [submodule "ncar-physics"] path = src/physics/ncar_ccpp url = https://github.com/ESCOMP/atmospheric_physics - fxtag = atmos_phys0_05_000 + fxtag = atmos_phys0_05_001 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics [submodule "ccs_config"] diff --git a/cime_config/cam_autogen.py b/cime_config/cam_autogen.py index eeb31229..863806ec 100644 --- a/cime_config/cam_autogen.py +++ b/cime_config/cam_autogen.py @@ -435,10 +435,15 @@ def generate_physics_suites(build_cache, preproc_defs, host_name, if not os.path.exists(physics_blddir): os.makedirs(physics_blddir) # End if - # Collect all source directories - atm_phys_src_dir = os.path.join(atm_root, "src", "physics", "ncar_ccpp") - source_search = [source_mods_dir, atm_phys_src_dir] - # Find all metadata files, organize by scheme name + # Set top-level CCPP physics directory + atm_phys_top_dir = os.path.join(atm_root, "src", "physics", "ncar_ccpp") + # Collect all possible Suite Definition File (SDF) locations + atm_suites_path = os.path.join(atm_phys_top_dir, "suites") + atm_test_suites_path = os.path.join(atm_phys_top_dir, "test", "test_suites") + suite_search = [source_mods_dir, atm_suites_path, atm_test_suites_path] + # Find all scheme metadata files, organized by scheme name + atm_schemes_path = os.path.join(atm_phys_top_dir, "schemes") + source_search = [source_mods_dir, atm_schemes_path] all_scheme_files = _find_metadata_files(source_search, find_scheme_names) # Find the SDFs specified for this model build @@ -446,11 +451,15 @@ def generate_physics_suites(build_cache, preproc_defs, host_name, scheme_files = [] xml_files = {} # key is scheme, value is xml file path for sdf in phys_suites_str.split(';'): - sdf_path = _find_file(f"suite_{sdf}.xml", source_search) + sdf_path = _find_file(f"suite_{sdf}.xml", suite_search) if not sdf_path: emsg = f"ERROR: Unable to find SDF for suite '{sdf}'" raise CamAutoGenError(emsg) # End if + if os.path.dirname(os.path.abspath(sdf_path)) == atm_test_suites_path: + #Notify user that a test suite is being used + _LOGGER.info("Using non-standard test suite: %s", sdf) + # End if sdfs.append(sdf_path) # Given an SDF, find all the schemes it calls _, suite = read_xml_file(sdf_path) @@ -587,7 +596,7 @@ def generate_physics_suites(build_cache, preproc_defs, host_name, # there to the bld directory: if do_gen_ccpp: # Set CCPP physics "utilities" path - atm_phys_util_dir = os.path.join(atm_phys_src_dir, "utilities") + atm_phys_util_dir = os.path.join(atm_schemes_path, "utilities") # Check that directory exists if not os.path.isdir(atm_phys_util_dir): diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 9b715c97..c93a9de8 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -159,12 +159,10 @@ -nlev 145 --> - + + --physics-suites tj2016 --analytic_ic + --physics-suites kessler --analytic_ic --physics-suites held_suarez_1994 --analytic_ic --dyn none --physics-suites adiabatic diff --git a/src/physics/ncar_ccpp b/src/physics/ncar_ccpp index 93a1dbf9..f8ce60bf 160000 --- a/src/physics/ncar_ccpp +++ b/src/physics/ncar_ccpp @@ -1 +1 @@ -Subproject commit 93a1dbf9c47ccedb8d8a48eba640e48ab2048774 +Subproject commit f8ce60bf40f800623f8eb3065021ec5dfa9e6b45 diff --git a/test/include/Makefile b/test/include/Makefile deleted file mode 100644 index 699930a6..00000000 --- a/test/include/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -FC = gfortran -FFLAGS = -c -DCPRGNU - -SOURCES = shr_kind_mod.F90 shr_infnan_mod.F90 ccpp_kinds.F90 cam_abortutils.F90 -SOURCES += spmd_utils.F90 cam_logfile.F90 -OBJS = $(SOURCES:.F90=.o) - -all: objs - -objs: $(SOURCES) - $(FC) $(FFLAGS) $(SOURCES) - -clean: - ${RM} *.o *.mod diff --git a/test/include/cam_abortutils.F90 b/test/include/cam_abortutils.F90 deleted file mode 100644 index 8db9729e..00000000 --- a/test/include/cam_abortutils.F90 +++ /dev/null @@ -1,17 +0,0 @@ -module cam_abortutils - - implicit none - private - - public endrun - -CONTAINS - - subroutine endrun(msg) - character(len=*), intent(in) :: msg - - write(6, *) msg - STOP - end subroutine endrun - -end module cam_abortutils diff --git a/test/include/cam_logfile.F90 b/test/include/cam_logfile.F90 deleted file mode 100644 index 8e1a8998..00000000 --- a/test/include/cam_logfile.F90 +++ /dev/null @@ -1,96 +0,0 @@ -module cam_logfile - -!----------------------------------------------------------------------- -! -! Purpose: This module is responsible for managing the logical unit -! of CAM's output log -! -! Author: mvr, Sep 2007 -! -!----------------------------------------------------------------------- - -!----------------------------------------------------------------------- -!- use statements ------------------------------------------------------ -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -!- module boilerplate -------------------------------------------------- -!----------------------------------------------------------------------- - implicit none - private - save - -!----------------------------------------------------------------------- -! Public interfaces ---------------------------------------------------- -!----------------------------------------------------------------------- - public :: cam_set_log_unit - public :: cam_logfile_readnl - public :: cam_log_multiwrite -!----------------------------------------------------------------------- -! Public data ---------------------------------------------------------- -!----------------------------------------------------------------------- - integer, public, protected :: iulog = 6 - integer, public, parameter :: DEBUGOUT_NONE = 0 - integer, public, parameter :: DEBUGOUT_INFO = 1 - integer, public, parameter :: DEBUGOUT_VERBOSE = 2 - integer, public, parameter :: DEBUGOUT_DEBUG = 3 - integer, public, protected :: debug_output = DEBUGOUT_NONE - -!----------------------------------------------------------------------- -! Private data --------------------------------------------------------- -!----------------------------------------------------------------------- - logical :: iulog_set = .true. - - interface cam_log_multiwrite - module procedure cam_log_multiwrite_ni ! Multiple integers - end interface cam_log_multiwrite - -CONTAINS - -!----------------------------------------------------------------------- -! Subroutines and functions -------------------------------------------- -!----------------------------------------------------------------------- - - subroutine cam_set_log_unit(unit_num) - - integer, intent(in) :: unit_num - - ! Change iulog to unit_num on this PE or log a waring - ! The log unit number can be set at most once per run - if (iulog_set) then - write(iulog, *) 'cam_set_log_unit: Cannot change log unit during run' - else - iulog = unit_num - iulog_set = .true. - end if - end subroutine cam_set_log_unit - - subroutine cam_logfile_readnl(nlfile) - - ! nlfile: filepath for file containing namelist input - character(len=*), intent(in) :: nlfile - - end subroutine cam_logfile_readnl - - subroutine cam_log_multiwrite_ni(subname, headers, fmt_string, values) - ! Print out values from every task - use spmd_utils, only: masterproc - - ! Dummy arguments - character(len=*), intent(in) :: subname - character(len=*), intent(in) :: headers - character(len=*), intent(in) :: fmt_string - integer, intent(in) :: values(:) - ! Local variables - integer :: num_fields - integer :: fnum - - num_fields = size(values, 1) - - if (masterproc) then - write(iulog, '(2a)') trim(subname), trim(headers) - write(iulog, fmt_string) subname, 0, & - (values(fnum), fnum = 1, num_fields) - end if - end subroutine cam_log_multiwrite_ni - -end module cam_logfile diff --git a/test/include/ccpp_kinds.F90 b/test/include/ccpp_kinds.F90 deleted file mode 100644 index c90c9cae..00000000 --- a/test/include/ccpp_kinds.F90 +++ /dev/null @@ -1,10 +0,0 @@ -module ccpp_kinds - - use ISO_FORTRAN_ENV, only: kind_phys => REAL64 - - implicit none - private - - public kind_phys - -end module ccpp_kinds diff --git a/test/include/shr_infnan_mod.F90 b/test/include/shr_infnan_mod.F90 deleted file mode 100644 index 8863882d..00000000 --- a/test/include/shr_infnan_mod.F90 +++ /dev/null @@ -1,1907 +0,0 @@ -! This file is a stand-in for CIME's shr_infnan_mod.F90.in -!=================================================== - -! Flag representing compiler support of Fortran 2003's -! ieee_arithmetic intrinsic module. -#if defined CPRIBM || defined CPRPGI || defined CPRINTEL || defined CPRCRAY || defined CPRNAG -#define HAVE_IEEE_ARITHMETIC -#endif - -module shr_infnan_mod -!--------------------------------------------------------------------- -! Module to test for IEEE Inf and NaN values, which also provides a -! method of setting +/-Inf and signaling or quiet NaN. -! -! All functions are elemental, and thus work on arrays. -!--------------------------------------------------------------------- -! To test for these values, just call the corresponding function, e.g: -! -! var_is_nan = shr_infnan_isnan(x) -! -! You can also use it on arrays: -! -! array_contains_nan = any(shr_infnan_isnan(my_array)) -! -!--------------------------------------------------------------------- -! To generate these values, assign one of the provided derived-type -! variables to a real: -! -! use shr_infnan_mod, only: nan => shr_infnan_nan, & -! inf => shr_infnan_inf, & -! assignment(=) -! real(r4) :: my_nan -! real(r8) :: my_inf_array(2,2) -! my_nan = nan -! my_inf_array = inf -! -! Keep in mind that "shr_infnan_nan" and "shr_infnan_inf" cannot be -! passed to functions that expect real arguments. To pass a real -! NaN, you will have to use shr_infnan_nan to set a local real of -! the correct kind. -!--------------------------------------------------------------------- - -use shr_kind_mod, only: & - r4 => SHR_KIND_R4, & - r8 => SHR_KIND_R8 - -#ifdef HAVE_IEEE_ARITHMETIC - -! If we have IEEE_ARITHMETIC, the NaN test is provided for us. -use, intrinsic :: ieee_arithmetic, only: & - shr_infnan_isnan => ieee_is_nan - -#else - -! Integers of correct size for bit patterns below. -use shr_kind_mod, only: i4 => shr_kind_i4, i8 => shr_kind_i8 - -#endif - -implicit none -private -save - -! Test functions for NaN/Inf values. -public :: shr_infnan_isnan -public :: shr_infnan_isinf -public :: shr_infnan_isposinf -public :: shr_infnan_isneginf - -! Locally defined isnan. -#ifndef HAVE_IEEE_ARITHMETIC - -interface shr_infnan_isnan - ! TYPE double,real - module procedure shr_infnan_isnan_double - ! TYPE double,real - module procedure shr_infnan_isnan_real -end interface -#endif - - -interface shr_infnan_isinf - ! TYPE double,real - module procedure shr_infnan_isinf_double - ! TYPE double,real - module procedure shr_infnan_isinf_real -end interface - - -interface shr_infnan_isposinf - ! TYPE double,real - module procedure shr_infnan_isposinf_double - ! TYPE double,real - module procedure shr_infnan_isposinf_real -end interface - - -interface shr_infnan_isneginf - ! TYPE double,real - module procedure shr_infnan_isneginf_double - ! TYPE double,real - module procedure shr_infnan_isneginf_real -end interface - -! Derived types for generation of NaN/Inf -! Even though there's no reason to "use" the types directly, some compilers -! might have trouble with an object being used without its type. -public :: shr_infnan_nan_type -public :: shr_infnan_inf_type -public :: assignment(=) -public :: shr_infnan_to_r4 -public :: shr_infnan_to_r8 - -! Type representing Not A Number. -type :: shr_infnan_nan_type - logical :: quiet = .false. -end type shr_infnan_nan_type - -! Type representing +/-Infinity. -type :: shr_infnan_inf_type - logical :: positive = .true. -end type shr_infnan_inf_type - -! Allow assigning reals to NaN or Inf. - -interface assignment(=) - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_0d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_1d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_2d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_3d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_4d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_5d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_6d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_7d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_0d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_1d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_2d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_3d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_4d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_5d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_6d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_nan_7d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_0d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_1d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_2d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_3d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_4d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_5d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_6d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_7d_double - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_0d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_1d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_2d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_3d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_4d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_5d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_6d_real - ! TYPE double,real - ! DIMS 0,1,2,3,4,5,6,7 - module procedure set_inf_7d_real -end interface - -! Conversion functions. - -interface shr_infnan_to_r8 - module procedure nan_r8 - module procedure inf_r8 -end interface - - -interface shr_infnan_to_r4 - module procedure nan_r4 - module procedure inf_r4 -end interface - -! Initialize objects of NaN/Inf type for other modules to use. - -! Default NaN is signaling, but also provide snan and qnan to choose -! explicitly. -type(shr_infnan_nan_type), public, parameter :: shr_infnan_nan = & - shr_infnan_nan_type(.false.) -type(shr_infnan_nan_type), public, parameter :: shr_infnan_snan = & - shr_infnan_nan_type(.false.) -type(shr_infnan_nan_type), public, parameter :: shr_infnan_qnan = & - shr_infnan_nan_type(.true.) - -! Default Inf is positive, but provide posinf to go with neginf. -type(shr_infnan_inf_type), public, parameter :: shr_infnan_inf = & - shr_infnan_inf_type(.true.) -type(shr_infnan_inf_type), public, parameter :: shr_infnan_posinf = & - shr_infnan_inf_type(.true.) -type(shr_infnan_inf_type), public, parameter :: shr_infnan_neginf = & - shr_infnan_inf_type(.false.) - -! Bit patterns for implementation without ieee_arithmetic. -! Note that in order to satisfy gfortran's range check, we have to use -! ibset to set the sign bit from a BOZ pattern. -#ifndef HAVE_IEEE_ARITHMETIC -! Single precision. -integer(i4), parameter :: ssnan_pat = int(Z'7FA00000',i4) -integer(i4), parameter :: sqnan_pat = int(Z'7FC00000',i4) -integer(i4), parameter :: sposinf_pat = int(Z'7F800000',i4) -integer(i4), parameter :: sneginf_pat = ibset(sposinf_pat,bit_size(1_i4)-1) -! Double precision. -integer(i8), parameter :: dsnan_pat = int(Z'7FF4000000000000',i8) -integer(i8), parameter :: dqnan_pat = int(Z'7FF8000000000000',i8) -integer(i8), parameter :: dposinf_pat = int(Z'7FF0000000000000',i8) -integer(i8), parameter :: dneginf_pat = ibset(dposinf_pat,bit_size(1_i8)-1) -#endif - - -contains - -!--------------------------------------------------------------------- -! TEST FUNCTIONS -!--------------------------------------------------------------------- -! The "isinf" function simply calls "isposinf" and "isneginf". -!--------------------------------------------------------------------- - -! TYPE double,real - -elemental function shr_infnan_isinf_double(x) result(isinf) - real(r8), intent(in) :: x - logical :: isinf - - isinf = shr_infnan_isposinf(x) .or. shr_infnan_isneginf(x) - - -end function shr_infnan_isinf_double -! TYPE double,real - -elemental function shr_infnan_isinf_real(x) result(isinf) - real(r4), intent(in) :: x - logical :: isinf - - isinf = shr_infnan_isposinf(x) .or. shr_infnan_isneginf(x) - - -end function shr_infnan_isinf_real - -#ifdef HAVE_IEEE_ARITHMETIC - -!--------------------------------------------------------------------- -! The "isposinf" and "isneginf" functions get the IEEE class of a -! real, and test to see if the class is equal to ieee_positive_inf -! or ieee_negative_inf. -!--------------------------------------------------------------------- - -! TYPE double,real - -elemental function shr_infnan_isposinf_double(x) result(isposinf) - use, intrinsic :: ieee_arithmetic, only: & - ieee_class, & - ieee_positive_inf, & - operator(==) - real(r8), intent(in) :: x - logical :: isposinf - - isposinf = (ieee_positive_inf == ieee_class(x)) - - -end function shr_infnan_isposinf_double -! TYPE double,real - -elemental function shr_infnan_isposinf_real(x) result(isposinf) - use, intrinsic :: ieee_arithmetic, only: & - ieee_class, & - ieee_positive_inf, & - operator(==) - real(r4), intent(in) :: x - logical :: isposinf - - isposinf = (ieee_positive_inf == ieee_class(x)) - - -end function shr_infnan_isposinf_real - -! TYPE double,real - -elemental function shr_infnan_isneginf_double(x) result(isneginf) - use, intrinsic :: ieee_arithmetic, only: & - ieee_class, & - ieee_negative_inf, & - operator(==) - real(r8), intent(in) :: x - logical :: isneginf - - isneginf = (ieee_negative_inf == ieee_class(x)) - - -end function shr_infnan_isneginf_double -! TYPE double,real - -elemental function shr_infnan_isneginf_real(x) result(isneginf) - use, intrinsic :: ieee_arithmetic, only: & - ieee_class, & - ieee_negative_inf, & - operator(==) - real(r4), intent(in) :: x - logical :: isneginf - - isneginf = (ieee_negative_inf == ieee_class(x)) - - -end function shr_infnan_isneginf_real - -#else -! Don't have ieee_arithmetic. - -#ifdef CPRGNU -! NaN testing on gfortran. -! TYPE double,real - -elemental function shr_infnan_isnan_double(x) result(is_nan) - real(r8), intent(in) :: x - logical :: is_nan - - is_nan = isnan(x) - - -end function shr_infnan_isnan_double -! TYPE double,real - -elemental function shr_infnan_isnan_real(x) result(is_nan) - real(r4), intent(in) :: x - logical :: is_nan - - is_nan = isnan(x) - - -end function shr_infnan_isnan_real -! End GNU section. -#endif - -!--------------------------------------------------------------------- -! The "isposinf" and "isneginf" functions just test against a known -! bit pattern if we don't have ieee_arithmetic. -!--------------------------------------------------------------------- - -! TYPE double,real - -elemental function shr_infnan_isposinf_double(x) result(isposinf) - real(r8), intent(in) :: x - logical :: isposinf -#if (102 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat -#endif - - isposinf = (x == transfer(posinf_pat,x)) - - -end function shr_infnan_isposinf_double -! TYPE double,real - -elemental function shr_infnan_isposinf_real(x) result(isposinf) - real(r4), intent(in) :: x - logical :: isposinf -#if (101 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat -#endif - - isposinf = (x == transfer(posinf_pat,x)) - - -end function shr_infnan_isposinf_real - -! TYPE double,real - -elemental function shr_infnan_isneginf_double(x) result(isneginf) - real(r8), intent(in) :: x - logical :: isneginf -#if (102 == TYPEREAL) - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif - - isneginf = (x == transfer(neginf_pat,x)) - - -end function shr_infnan_isneginf_double -! TYPE double,real - -elemental function shr_infnan_isneginf_real(x) result(isneginf) - real(r4), intent(in) :: x - logical :: isneginf -#if (101 == TYPEREAL) - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif - - isneginf = (x == transfer(neginf_pat,x)) - - -end function shr_infnan_isneginf_real - -! End ieee_arithmetic conditional. -#endif - -!--------------------------------------------------------------------- -! GENERATION FUNCTIONS -!--------------------------------------------------------------------- -! Two approaches for generation of NaN and Inf values: -! 1. With Fortran 2003, use the ieee_value intrinsic to get a value -! from the corresponding class. These are: -! - ieee_signaling_nan -! - ieee_quiet_nan -! - ieee_positive_inf -! - ieee_negative_inf -! 2. Without Fortran 2003, set the IEEE bit patterns directly. -! Use BOZ literals to get an integer with the correct bit -! pattern, then use "transfer" to transfer those bits into a -! real. -!--------------------------------------------------------------------- - -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_0d_double(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r8), intent(out) :: output - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_0d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_1d_double(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r8), intent(out) :: output(:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_1d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_2d_double(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r8), intent(out) :: output(:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_2d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_3d_double(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r8), intent(out) :: output(:,:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_3d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_4d_double(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r8), intent(out) :: output(:,:,:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_4d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_5d_double(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r8), intent(out) :: output(:,:,:,:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_5d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_6d_double(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r8), intent(out) :: output(:,:,:,:,:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_6d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_7d_double(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r8), intent(out) :: output(:,:,:,:,:,:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_7d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_0d_real(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r4), intent(out) :: output - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_0d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_1d_real(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r4), intent(out) :: output(:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_1d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_2d_real(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r4), intent(out) :: output(:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_2d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_3d_real(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r4), intent(out) :: output(:,:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_3d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_4d_real(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r4), intent(out) :: output(:,:,:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_4d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_5d_real(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r4), intent(out) :: output(:,:,:,:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_5d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_6d_real(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r4), intent(out) :: output(:,:,:,:,:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_6d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_nan_7d_real(output, nan) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_signaling_nan, & - ieee_quiet_nan, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: snan_pat = ssnan_pat - integer(i4), parameter :: qnan_pat = sqnan_pat -#else - integer(i8), parameter :: snan_pat = dsnan_pat - integer(i8), parameter :: qnan_pat = dqnan_pat -#endif -#endif - real(r4), intent(out) :: output(:,:,:,:,:,:,:) - type(shr_infnan_nan_type), intent(in) :: nan - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (nan%quiet) then - tmp = ieee_value(tmp, ieee_quiet_nan) - else - tmp = ieee_value(tmp, ieee_signaling_nan) - end if -#else - if (nan%quiet) then - tmp = transfer(qnan_pat, tmp) - else - tmp = transfer(snan_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_nan_7d_real - -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_0d_double(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r8), intent(out) :: output - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_0d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_1d_double(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r8), intent(out) :: output(:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_1d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_2d_double(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r8), intent(out) :: output(:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_2d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_3d_double(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r8), intent(out) :: output(:,:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_3d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_4d_double(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r8), intent(out) :: output(:,:,:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_4d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_5d_double(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r8), intent(out) :: output(:,:,:,:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_5d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_6d_double(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r8), intent(out) :: output(:,:,:,:,:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_6d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_7d_double(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (102 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r8), intent(out) :: output(:,:,:,:,:,:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r8) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_7d_double -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_0d_real(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r4), intent(out) :: output - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_0d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_1d_real(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r4), intent(out) :: output(:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_1d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_2d_real(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r4), intent(out) :: output(:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_2d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_3d_real(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r4), intent(out) :: output(:,:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_3d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_4d_real(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r4), intent(out) :: output(:,:,:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_4d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_5d_real(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r4), intent(out) :: output(:,:,:,:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_5d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_6d_real(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r4), intent(out) :: output(:,:,:,:,:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_6d_real -! TYPE double,real -! DIMS 0,1,2,3,4,5,6,7 - -pure subroutine set_inf_7d_real(output, inf) -#ifdef HAVE_IEEE_ARITHMETIC - use, intrinsic :: ieee_arithmetic, only: & - ieee_positive_inf, & - ieee_negative_inf, & - ieee_value -#else -#if (101 == TYPEREAL) - integer(i4), parameter :: posinf_pat = sposinf_pat - integer(i4), parameter :: neginf_pat = sneginf_pat -#else - integer(i8), parameter :: posinf_pat = dposinf_pat - integer(i8), parameter :: neginf_pat = dneginf_pat -#endif -#endif - real(r4), intent(out) :: output(:,:,:,:,:,:,:) - type(shr_infnan_inf_type), intent(in) :: inf - - ! Use scalar temporary for performance reasons, to reduce the cost of - ! the ieee_value call. - real(r4) :: tmp - -#ifdef HAVE_IEEE_ARITHMETIC - if (inf%positive) then - tmp = ieee_value(tmp,ieee_positive_inf) - else - tmp = ieee_value(tmp,ieee_negative_inf) - end if -#else - if (inf%positive) then - tmp = transfer(posinf_pat, tmp) - else - tmp = transfer(neginf_pat, tmp) - end if -#endif - - output = tmp - - -end subroutine set_inf_7d_real - -!--------------------------------------------------------------------- -! CONVERSION INTERFACES. -!--------------------------------------------------------------------- -! Function methods to get reals from nan/inf types. -!--------------------------------------------------------------------- - - -pure function nan_r8(nan) result(output) - class(shr_infnan_nan_type), intent(in) :: nan - real(r8) :: output - - output = nan - - -end function nan_r8 - - -pure function nan_r4(nan) result(output) - class(shr_infnan_nan_type), intent(in) :: nan - real(r4) :: output - - output = nan - - -end function nan_r4 - - -pure function inf_r8(inf) result(output) - class(shr_infnan_inf_type), intent(in) :: inf - real(r8) :: output - - output = inf - - -end function inf_r8 - - -pure function inf_r4(inf) result(output) - class(shr_infnan_inf_type), intent(in) :: inf - real(r4) :: output - - output = inf - - -end function inf_r4 - -end module shr_infnan_mod diff --git a/test/include/shr_kind_mod.F90 b/test/include/shr_kind_mod.F90 deleted file mode 100644 index e9e7d170..00000000 --- a/test/include/shr_kind_mod.F90 +++ /dev/null @@ -1,19 +0,0 @@ -MODULE shr_kind_mod - - !---------------------------------------------------------------------------- - ! precision/kind constants add data public - !---------------------------------------------------------------------------- - public - integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real - integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real - integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real - integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer - integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer - integer,parameter :: SHR_KIND_IN = kind(1) ! native integer - integer,parameter :: SHR_KIND_CS = 80 ! short char - integer,parameter :: SHR_KIND_CM = 160 ! mid-sized char - integer,parameter :: SHR_KIND_CL = 256 ! long char - integer,parameter :: SHR_KIND_CX = 512 ! extra-long char - integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char - -END MODULE shr_kind_mod diff --git a/test/include/spmd_utils.F90 b/test/include/spmd_utils.F90 deleted file mode 100644 index c827ac56..00000000 --- a/test/include/spmd_utils.F90 +++ /dev/null @@ -1,11 +0,0 @@ -module spmd_utils - - implicit none - private - - integer, parameter, public :: masterprocid = 0 - integer, parameter, public :: iam = 0 - integer, parameter, public :: npes = 1 - logical, parameter, public :: masterproc = .true. - -end module spmd_utils