From a055c2c3175eb4f87569acfbe5accd7c9995ba57 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Thu, 13 Jun 2024 16:01:50 -0600 Subject: [PATCH 01/47] Update CMakeLists.txt add shared directory to cmake build --- CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 70172df11..8e50ee2e9 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -45,4 +45,5 @@ if(BLD_STANDALONE) list(APPEND EXTRA_INCLUDES "${CMAKE_BINARY_DIR}/ufs") endif() +add_subdirectory(shared) add_subdirectory(mediator) From eb79b62830ae87c45bea51cbeb34d601898ab825 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Thu, 13 Jun 2024 16:06:31 -0600 Subject: [PATCH 02/47] Create CMakeLists.txt added new CMakeLists.txt file for shared directory --- shared/CMakeLists.txt | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 shared/CMakeLists.txt diff --git a/shared/CMakeLists.txt b/shared/CMakeLists.txt new file mode 100644 index 000000000..79949528b --- /dev/null +++ b/shared/CMakeLists.txt @@ -0,0 +1,8 @@ +project(shared Fortran) +include(ExternalProject) + +add_library(shared shr_infnan_mod.F90 shr_kind_mod.F90 shr_orb_mod.F90 shr_sys_mod.F90 shr_sys_mod.F90 shr_sys_mod.F90 shr_sys_mod.F90 shr_log_mod.F90 shr_strconvert_mod.F90 shr_abort_mod.F90 shr_const_mod.F90) + +target_include_directories (shared PUBLIC ${CMAKE_CURRENT_SOURCE_DIR} ${ESMF_F90COMPILEPATHS} ${PIO_Fortran_INCLUDE_DIRS}) + +target_compile_definitions(shared PUBLIC HAVE_IEEE_ARITHMETIC) From d14556ccf4be1763952b17b04186300798bc73f4 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Thu, 13 Jun 2024 16:18:17 -0600 Subject: [PATCH 03/47] add shared files from UFS and CDEPS --- shared/dtypes.h | 6 + shared/shr_abort_mod.F90 | 158 +++ shared/shr_const_mod.F90 | 105 ++ shared/shr_infnan_mod.F90 | 1805 +++++++++++++++++++++++++++++++++ shared/shr_kind_mod.F90 | 20 + shared/shr_log_mod.F90 | 120 +++ shared/shr_orb_mod.F90 | 811 +++++++++++++++ shared/shr_strconvert_mod.F90 | 166 +++ shared/shr_sys_mod.F90 | 331 ++++++ 9 files changed, 3522 insertions(+) create mode 100644 shared/dtypes.h create mode 100644 shared/shr_abort_mod.F90 create mode 100644 shared/shr_const_mod.F90 create mode 100644 shared/shr_infnan_mod.F90 create mode 100644 shared/shr_kind_mod.F90 create mode 100644 shared/shr_log_mod.F90 create mode 100644 shared/shr_orb_mod.F90 create mode 100644 shared/shr_strconvert_mod.F90 create mode 100644 shared/shr_sys_mod.F90 diff --git a/shared/dtypes.h b/shared/dtypes.h new file mode 100644 index 000000000..f2e5b000f --- /dev/null +++ b/shared/dtypes.h @@ -0,0 +1,6 @@ +#define TYPETEXT 100 +#define TYPEREAL 101 +#define TYPEDOUBLE 102 +#define TYPEINT 103 +#define TYPELONG 104 +#define TYPELOGICAL 105 diff --git a/shared/shr_abort_mod.F90 b/shared/shr_abort_mod.F90 new file mode 100644 index 000000000..230cb61e2 --- /dev/null +++ b/shared/shr_abort_mod.F90 @@ -0,0 +1,158 @@ +module shr_abort_mod + ! This module defines procedures that can be used to abort the model cleanly in a + ! system-specific manner + ! + ! The public routines here are only meant to be used directly by shr_sys_mod. Other code + ! that wishes to use these routines should use the republished names from shr_sys_mod + ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from + ! when these routines were defined in shr_sys_mod.) + + use, intrinsic :: iso_fortran_env, only: output_unit, error_unit + use ESMF, only : ESMF_Finalize, ESMF_END_ABORT, ESMF_LOGMSG_ERROR, ESMF_LogWrite + use shr_kind_mod, only : shr_kind_in, shr_kind_cx + use shr_log_mod , only : s_logunit => shr_log_Unit + +#ifdef CPRNAG + ! NAG does not provide this as an intrinsic, but it does provide modules + ! that implement commonly used POSIX routines. + use f90_unix_proc, only: abort +#endif + + implicit none + + ! PUBLIC: Public interfaces + + private + + ! The public routines here are only meant to be used directly by shr_sys_mod. Other code + ! that wishes to use these routines should use the republished names from shr_sys_mod + ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from + ! when these routines were defined in shr_sys_mod.) + public :: shr_abort_abort ! abort a program + public :: shr_abort_backtrace ! print a backtrace, if possible + +contains + + !=============================================================================== + subroutine shr_abort_abort(string,rc) + ! Consistent stopping mechanism + + !----- arguments ----- + character(len=*) , intent(in), optional :: string ! error message string + integer(shr_kind_in), intent(in), optional :: rc ! error code + + !----- local ----- + + ! Local version of the string. + ! (Gets a default value if string is not present.) + character(len=shr_kind_cx) :: local_string + !------------------------------------------------------------------------------- + + if (present(string)) then + local_string = trim(string) + else + local_string = "Unknown error submitted to shr_abort_abort." + end if + + call print_error_to_logs("ERROR", local_string) + + call shr_abort_backtrace() + + if(present(rc)) then + write(local_string, *) trim(local_string), ' rc=',rc + endif + call ESMF_LogWrite(local_string, ESMF_LOGMSG_ERROR) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + + ! A compiler's abort method may print a backtrace or do other nice + ! things, but in fact we can rarely leverage this, because MPI_Abort + ! usually sends SIGTERM to the process, and we don't catch that signal. + call abort() + + end subroutine shr_abort_abort + !=============================================================================== + + !=============================================================================== + subroutine shr_abort_backtrace() + ! This routine uses compiler-specific facilities to print a backtrace to + ! error_unit (standard error, usually unit 0). + +#if defined(CPRIBM) + + ! This theoretically should be in xlfutility, but using it from that + ! module doesn't seem to always work. + interface + subroutine xl_trbk() + end subroutine xl_trbk + end interface + + call xl__trbk() + +#elif defined(CPRGNU) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8 )) + + ! gfortran 4.8 and later implement this intrinsic. We explicitly call it + ! out as such to make sure that it really is available, just in case the + ! CPP logic above screws up. + intrinsic :: backtrace + + call backtrace() + +#elif defined(CPRINTEL) + + ! tracebackqq uses optional arguments, so *must* have an explicit + ! interface. + use ifcore, only: tracebackqq + + ! An exit code of -1 is a special value that prevents this subroutine + ! from aborting the run. + call tracebackqq(user_exit_code=-1) + +#else + + ! Currently we have no means to request a backtrace from the NAG runtime, + ! even though it is capable of emitting backtraces itself, if you use the + ! "-gline" option. + + ! Similarly, PGI has a -traceback option, but no user interface for + ! requesting a backtrace to be printed. + +#endif + + flush(error_unit) + + end subroutine shr_abort_backtrace + !=============================================================================== + + !=============================================================================== + subroutine print_error_to_logs(error_type, message) + ! This routine prints error messages to s_logunit (which is standard output + ! for most tasks in CESM) and also to standard error if s_logunit is a + ! file. + ! + ! It also flushes these output units. + + character(len=*), intent(in) :: error_type, message + + integer, allocatable :: log_units(:) + + integer :: i + + if (s_logunit == output_unit .or. s_logunit == error_unit) then + ! If the log unit number is standard output or standard error, just + ! print to that. + allocate(log_units(1), source=[s_logunit]) + else + ! Otherwise print the same message to both the log unit and standard + ! error. + allocate(log_units(2), source=[error_unit, s_logunit]) + end if + + do i = 1, size(log_units) + write(log_units(i),*) trim(error_type), ": ", trim(message) + flush(log_units(i)) + end do + + end subroutine print_error_to_logs + !=============================================================================== + +end module shr_abort_mod diff --git a/shared/shr_const_mod.F90 b/shared/shr_const_mod.F90 new file mode 100644 index 000000000..8437190c7 --- /dev/null +++ b/shared/shr_const_mod.F90 @@ -0,0 +1,105 @@ +!=============================================================================== +! SVN $Id: shr_const_mod.F90 61510 2014-06-26 21:58:56Z tcraig $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_const_mod.F90 $ +!=============================================================================== + +MODULE shr_const_mod + + use shr_kind_mod, only : R8 => shr_kind_r8 + + !---------------------------------------------------------------------------- + ! physical constants (all data public) + !---------------------------------------------------------------------------- + private :: R8 + public + + real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 ! pi + real(R8),parameter :: SHR_CONST_CDAY = 86400.0_R8 ! sec in calendar day ~ sec + real(R8),parameter :: SHR_CONST_SDAY = 86164.0_R8 ! sec in siderial day ~ sec + real(R8),parameter :: SHR_CONST_OMEGA = 2.0_R8*SHR_CONST_PI/SHR_CONST_SDAY ! earth rot ~ rad/sec + real(R8),parameter :: SHR_CONST_REARTH = 6.37122e6_R8 ! radius of earth ~ m + real(R8),parameter :: SHR_CONST_G = 9.80616_R8 ! acceleration of gravity ~ m/s^2 + + real(R8),parameter :: SHR_CONST_STEBOL = 5.67e-8_R8 ! Stefan-Boltzmann constant ~ W/m^2/K^4 + real(R8),parameter :: SHR_CONST_BOLTZ = 1.38065e-23_R8 ! Boltzmann's constant ~ J/K/molecule + real(R8),parameter :: SHR_CONST_AVOGAD = 6.02214e26_R8 ! Avogadro's number ~ molecules/kmole + real(R8),parameter :: SHR_CONST_RGAS = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ ! Universal gas constant ~ J/K/kmole + real(R8),parameter :: SHR_CONST_MWDAIR = 28.966_R8 ! molecular weight dry air ~ kg/kmole + real(R8),parameter :: SHR_CONST_MWWV = 18.016_R8 ! molecular weight water vapor + real(R8),parameter :: SHR_CONST_RDAIR = SHR_CONST_RGAS/SHR_CONST_MWDAIR ! Dry air gas constant ~ J/K/kg + real(R8),parameter :: SHR_CONST_RWV = SHR_CONST_RGAS/SHR_CONST_MWWV ! Water vapor gas constant ~ J/K/kg + real(R8),parameter :: SHR_CONST_ZVIR = (SHR_CONST_RWV/SHR_CONST_RDAIR)-1.0_R8 ! RWV/RDAIR - 1.0 + real(R8),parameter :: SHR_CONST_KARMAN = 0.4_R8 ! Von Karman constant + real(R8),parameter :: SHR_CONST_PSTD = 101325.0_R8 ! standard pressure ~ pascals + real(R8),parameter :: SHR_CONST_PDB = 0.0112372_R8 ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard) + + real(R8),parameter :: SHR_CONST_TKTRIP = 273.16_R8 ! triple point of fresh water ~ K + real(R8),parameter :: SHR_CONST_TKFRZ = 273.15_R8 ! freezing T of fresh water ~ K + real(R8),parameter :: SHR_CONST_TKFRZSW = SHR_CONST_TKFRZ - 1.8_R8 ! freezing T of salt water ~ K + real(R8),parameter :: SHR_CONST_ZSRFLYR = 3.0_R8 ! ocn surf layer depth for diurnal SST cal ~ m + + real(R8),parameter :: SHR_CONST_RHODAIR = & ! density of dry air at STP ~ kg/m^3 + SHR_CONST_PSTD/(SHR_CONST_RDAIR*SHR_CONST_TKFRZ) + real(R8),parameter :: SHR_CONST_RHOFW = 1.000e3_R8 ! density of fresh water ~ kg/m^3 + real(R8),parameter :: SHR_CONST_RHOSW = 1.026e3_R8 ! density of sea water ~ kg/m^3 + real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice ~ kg/m^3 + real(R8),parameter :: SHR_CONST_CPDAIR = 1.00464e3_R8 ! specific heat of dry air ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPWV = 1.810e3_R8 ! specific heat of water vap ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPVIR = (SHR_CONST_CPWV/SHR_CONST_CPDAIR)-1.0_R8 ! CPWV/CPDAIR - 1.0 + real(R8),parameter :: SHR_CONST_CPFW = 4.188e3_R8 ! specific heat of fresh h2o ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPSW = 3.996e3_R8 ! specific heat of sea h2o ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPICE = 2.11727e3_R8 ! specific heat of fresh ice ~ J/kg/K + real(R8),parameter :: SHR_CONST_LATICE = 3.337e5_R8 ! latent heat of fusion ~ J/kg + real(R8),parameter :: SHR_CONST_LATVAP = 2.501e6_R8 ! latent heat of evaporation ~ J/kg + real(R8),parameter :: SHR_CONST_LATSUB = & ! latent heat of sublimation ~ J/kg + SHR_CONST_LATICE + SHR_CONST_LATVAP + real(R8),parameter :: SHR_CONST_CONDICE = 2.1_R8 ! thermal conductivity of ice ~ W/m/K + real(R8),parameter :: SHR_CONST_KAPPA_LAND_ICE = & ! Diffusivity of heat in land ice ~ + SHR_CONST_CONDICE / (SHR_CONST_RHOICE*SHR_CONST_CPICE) + real(R8),parameter :: SHR_CONST_TF0 = 6.22e-2_R8 ! The freezing temperature at zero pressure in + ! sub-ice-shelf ocean cavities ~ C + real(R8),parameter :: SHR_CONST_DTF_DP = -7.43e-8_R8 ! The coefficient for the term proportional to the (limited) + ! pressure in the freezing temperature in sub-ice-shelf ocean cavities. ~ C Pa^{-1} + real(R8),parameter :: SHR_CONST_DTF_DS = -5.63e-2_R8 !The coefficient for the term proportional to salinity in + ! the freezing temperature in sub-ice-ice ocean cavities ~ C PSU^{-1} + real(R8),parameter :: SHR_CONST_DTF_DPDS = -1.74e-10_R8 ! The coefficient for the term proportional to salinity times + ! pressure in the freezing temperature in sub-ice-shelf ocean cavities ~ C PSU^{-1} Pa^{-1} + real(R8),parameter :: SHR_CONST_OCN_REF_SAL = 34.7_R8 ! ocn ref salinity (psu) + real(R8),parameter :: SHR_CONST_ICE_REF_SAL = 4.0_R8 ! ice ref salinity (psu) + + real(R8),parameter :: SHR_CONST_SPVAL = 1.0e30_R8 ! special missing value + real(R8),parameter :: SHR_CONST_SPVAL_TOLMIN = 0.99_R8 * SHR_CONST_SPVAL ! min spval tolerance + real(R8),parameter :: SHR_CONST_SPVAL_TOLMAX = 1.01_R8 * SHR_CONST_SPVAL ! max spval tolerance + real(R8),parameter :: SHR_CONST_SPVAL_AERODEP= 1.e29_r8 ! special aerosol deposition + + !Water Isotope Ratios in Vienna Standard Mean Ocean Water (VSMOW): + real(R8),parameter :: SHR_CONST_VSMOW_18O = 2005.2e-6_R8 ! 18O/16O in VMSOW + real(R8),parameter :: SHR_CONST_VSMOW_17O = 379.e-6_R8 ! 18O/16O in VMSOW + real(R8),parameter :: SHR_CONST_VSMOW_16O = 0.997628_R8 ! 16O/Tot in VMSOW + real(R8),parameter :: SHR_CONST_VSMOW_D = 155.76e-6_R8 ! 2H/1H in VMSOW + real(R8),parameter :: SHR_CONST_VSMOW_T = 1.85e-6_R8 ! 3H/1H in VMSOW + real(R8),parameter :: SHR_CONST_VSMOW_H = 0.99984426_R8 ! 1H/Tot in VMSOW + ! For best numerics in CAM5 + real(R8),parameter :: SHR_CONST_RSTD_H2ODEV = 1.0_R8 ! Rstd Dev Use + +contains + +!----------------------------------------------------------------------------- + + elemental logical function shr_const_isspval(rval) +!$omp declare simd(shr_const_isspval) + + real(r8), intent(in) :: rval + + if (rval > SHR_CONST_SPVAL_TOLMIN .and. & + rval < SHR_CONST_SPVAL_TOLMAX) then + shr_const_isspval = .true. + else + shr_const_isspval = .false. + endif + + end function shr_const_isspval + +!----------------------------------------------------------------------------- + +END MODULE shr_const_mod diff --git a/shared/shr_infnan_mod.F90 b/shared/shr_infnan_mod.F90 new file mode 100644 index 000000000..7a818485c --- /dev/null +++ b/shared/shr_infnan_mod.F90 @@ -0,0 +1,1805 @@ +#include "dtypes.h" +!=================================================== +! DO NOT EDIT THIS FILE, it was generated using genf90.pl +! Any changes you make to this file may be lost +!=================================================== +! 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/shared/shr_kind_mod.F90 b/shared/shr_kind_mod.F90 new file mode 100644 index 000000000..be988e541 --- /dev/null +++ b/shared/shr_kind_mod.F90 @@ -0,0 +1,20 @@ +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_I2 = selected_int_kind ( 4) ! 2 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/shared/shr_log_mod.F90 b/shared/shr_log_mod.F90 new file mode 100644 index 000000000..a7e4c70e3 --- /dev/null +++ b/shared/shr_log_mod.F90 @@ -0,0 +1,120 @@ +!BOP =========================================================================== +! +! !MODULE: shr_log_mod -- variables and methods for logging +! +! !DESCRIPTION: +! Low-level shared variables for logging. +! +! Also, routines for generating log file messages. +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_log_mod + +! !USES: + + use shr_kind_mod, only: shr_kind_in, shr_kind_cx + use shr_strconvert_mod, only: toString + + use, intrinsic :: iso_fortran_env, only: output_unit + + implicit none + private + +! !PUBLIC TYPES: + + ! no public types + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_log_errMsg + public :: shr_log_OOBMsg + public :: shr_log_setLogUnit + public :: shr_log_getLogUnit + +! !PUBLIC DATA MEMBERS: + + public :: shr_log_Level + public :: shr_log_Unit + +!EOP + + ! low-level shared variables for logging, these may not be parameters + integer(SHR_KIND_IN) :: shr_log_Level = 0 + integer(SHR_KIND_IN) :: shr_log_Unit = output_unit + +contains + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_log_errMsg -- Return an error message containing file & line info +! +! !DESCRIPTION: +! Return an error message containing file & line info +! \newline +! errMsg = shr\_log\_errMsg(__FILE__, __LINE__) +! +! This is meant to be used when a routine expects a string argument for some message, +! but you want to provide file and line information. +! +! However: Note that the performance of this function can be very bad. It is currently +! maintained because it is used by old code, but you should probably avoid using this +! in new code if possible. +! +! !REVISION HISTORY: +! 2013-July-23 - Bill Sacks +! +! !INTERFACE: ------------------------------------------------------------------ + + pure function shr_log_errMsg(file, line) + + ! !INPUT/OUTPUT PARAMETERS: + + character(len=SHR_KIND_CX) :: shr_log_errMsg + character(len=*), intent(in) :: file + integer , intent(in) :: line + + !EOP + + shr_log_errMsg = 'ERROR in '//trim(file)//' at line '//toString(line) + + end function shr_log_errMsg + + ! Create a message for an out of bounds error. + pure function shr_log_OOBMsg(operation, bounds, idx) result(OOBMsg) + + ! A name for the operation being attempted when the bounds error + ! occurred. A string containing the subroutine name is ideal, but more + ! generic descriptions such as "read", "modify", or "insert" could be used. + character(len=*), intent(in) :: operation + + ! Upper and lower bounds allowed for the operation. + integer, intent(in) :: bounds(2) + + ! Index at which access was attempted. + integer, intent(in) :: idx + + ! Output message + character(len=:), allocatable :: OOBMsg + + allocate(OOBMsg, source=(operation//": "//toString(idx)//" not in range ["//& + toString(bounds(1))//", "//toString(bounds(2))//"].")) + + end function shr_log_OOBMsg + + subroutine shr_log_setLogUnit(unit) + integer, intent(in) :: unit + + shr_log_unit = unit + + end subroutine shr_log_setLogUnit + + subroutine shr_log_getLogUnit(unit) + integer, intent(out) :: unit + + unit = shr_log_unit + + end subroutine shr_log_getLogUnit + +end module shr_log_mod diff --git a/shared/shr_orb_mod.F90 b/shared/shr_orb_mod.F90 new file mode 100644 index 000000000..54ec1014f --- /dev/null +++ b/shared/shr_orb_mod.F90 @@ -0,0 +1,811 @@ +MODULE shr_orb_mod + + use shr_kind_mod, only: SHR_KIND_R8, SHR_KIND_IN + use shr_sys_mod, only: shr_sys_abort + use shr_const_mod, only: shr_const_pi + use shr_log_mod, only: shr_log_getLogUnit + + IMPLICIT none + + !---------------------------------------------------------------------------- + ! PUBLIC: Interfaces and global data + !---------------------------------------------------------------------------- + public :: shr_orb_cosz + public :: shr_orb_params + public :: shr_orb_decl + public :: shr_orb_print + public :: set_constant_zenith_angle_deg + + real (SHR_KIND_R8),public,parameter :: SHR_ORB_UNDEF_REAL = 1.e36_SHR_KIND_R8 ! undefined real + integer(SHR_KIND_IN),public,parameter :: SHR_ORB_UNDEF_INT = 2000000000 ! undefined int + + !---------------------------------------------------------------------------- + ! PRIVATE: by default everything else is private to this module + !---------------------------------------------------------------------------- + private + + real (SHR_KIND_R8),parameter :: pi = SHR_CONST_PI + real (SHR_KIND_R8),parameter :: SHR_ORB_ECCEN_MIN = 0.0_SHR_KIND_R8 ! min value for eccen + real (SHR_KIND_R8),parameter :: SHR_ORB_ECCEN_MAX = 0.1_SHR_KIND_R8 ! max value for eccen + real (SHR_KIND_R8),parameter :: SHR_ORB_OBLIQ_MIN = -90.0_SHR_KIND_R8 ! min value for obliq + real (SHR_KIND_R8),parameter :: SHR_ORB_OBLIQ_MAX = +90.0_SHR_KIND_R8 ! max value for obliq + real (SHR_KIND_R8),parameter :: SHR_ORB_MVELP_MIN = 0.0_SHR_KIND_R8 ! min value for mvelp + real (SHR_KIND_R8),parameter :: SHR_ORB_MVELP_MAX = 360.0_SHR_KIND_R8 ! max value for mvelp + + ! This variable overrides the behavior of shr_orb_cosz() when >=0 + ! this is be set by calling set_constant_zenith_angle_deg() + real (SHR_KIND_R8) :: constant_zenith_angle_deg = -1 ! constant, uniform zneith angle [degrees] + + !=============================================================================== +CONTAINS + !=============================================================================== + + SUBROUTINE set_constant_zenith_angle_deg(angle_deg) + real(SHR_KIND_R8),intent(in) :: angle_deg + constant_zenith_angle_deg = angle_deg + END SUBROUTINE set_constant_zenith_angle_deg + + !======================================================================= + !======================================================================= + + real(SHR_KIND_R8) pure FUNCTION shr_orb_cosz(jday,lat,lon,declin,dt_avg,uniform_angle) + + !---------------------------------------------------------------------------- + ! + ! FUNCTION to return the cosine of the solar zenith angle. + ! Assumes 365.0 days/year. + ! + !--------------- Code History ----------------------------------------------- + ! + ! Original Author: Brian Kauffman + ! Date: Jan/98 + ! History: adapted from statement FUNCTION in share/orb_cosz.h + ! + !---------------------------------------------------------------------------- + + real (SHR_KIND_R8),intent(in) :: jday ! Julian cal day (1.xx to 365.xx) + real (SHR_KIND_R8),intent(in) :: lat ! Centered latitude (radians) + real (SHR_KIND_R8),intent(in) :: lon ! Centered longitude (radians) + real (SHR_KIND_R8),intent(in) :: declin ! Solar declination (radians) + real (SHR_KIND_R8),intent(in), optional :: dt_avg ! if present and set non-zero, then use in the + real (SHR_KIND_R8),intent(in), optional :: uniform_angle ! if present and true, apply uniform insolation + ! average cosz calculation + logical :: use_dt_avg + + !---------------------------------------------------------------------------- + + if ( constant_zenith_angle_deg >= 0 ) then + shr_orb_cosz = cos( constant_zenith_angle_deg * SHR_CONST_PI/180. ) + return + end if + + if (present(uniform_angle)) then + shr_orb_cosz = cos(uniform_angle) + return + end if + + ! perform the calculation of shr_orb_cosz + use_dt_avg = .false. + if (present(dt_avg)) then + if (dt_avg /= 0.0_shr_kind_r8) use_dt_avg = .true. + end if + ! If dt for the average cosz is specified, then call the shr_orb_avg_cosz + if (use_dt_avg) then + shr_orb_cosz = shr_orb_avg_cosz(jday, lat, lon, declin, dt_avg) + else + shr_orb_cosz = sin(lat)*sin(declin) - cos(lat)*cos(declin) * & + cos((jday-floor(jday))*2.0_SHR_KIND_R8*pi + lon) + end if + + END FUNCTION shr_orb_cosz + + !======================================================================= + ! A New Algorithm for Calculation of Cosine Solar Zenith Angle + ! Author: Linjiong Zhou + ! E-mail: linjiongzhou@hotmail.com + ! Date : 2015.02.22 + ! Ref. : Zhou et al., GRL, 2015 + !======================================================================= + + real (SHR_KIND_R8) pure function shr_orb_avg_cosz(jday, lat, lon, declin, dt_avg) + + use shr_const_mod, only : pi => shr_const_pi + + implicit none + + !----------------------------------------------------------------------- + ! In/Out Arguements + + real(SHR_KIND_R8), intent(in) :: jday ! Julian calendar day (1.xx to 365.xx) + real(SHR_KIND_R8), intent(in) :: lat ! latitude (radian) + real(SHR_KIND_R8), intent(in) :: lon ! longitude (radian) + real(SHR_KIND_R8), intent(in) :: declin ! solar declination (radian) + real(SHR_KIND_R8), intent(in) :: dt_avg ! dt for averaged cosz calculation + + !----------------------------------------------------------------------- + ! Local Arguments + + real(SHR_KIND_R8),parameter :: piover2 = pi/2.0_SHR_KIND_R8 + real(SHR_KIND_R8),parameter :: twopi = pi*2.0_SHR_KIND_R8 + + real(SHR_KIND_R8) :: aa, bb + real(SHR_KIND_R8) :: del, phi + real(SHR_KIND_R8) :: cos_h, h + real(SHR_KIND_R8) :: t1, t2, dt + real(SHR_KIND_R8) :: tt1, tt2, tt3, tt4 + + !----------------------------------------------------------------------- + ! Compute Half-day Length + + ! adjust latitude so that its tangent will be defined + if (lat == piover2) then + del = lat - 1.0e-05_SHR_KIND_R8 + else if (lat == -piover2) then + del = lat + 1.0e-05_SHR_KIND_R8 + else + del = lat + end if + + ! adjust declination so that its tangent will be defined + if (declin == piover2) then + phi = declin - 1.0e-05_SHR_KIND_R8 + else if (declin == -piover2) then + phi = declin + 1.0e-05_SHR_KIND_R8 + else + phi = declin + end if + + ! define the cosine of the half-day length + ! adjust for cases of all daylight or all night + cos_h = - tan(del) * tan(phi) + if (cos_h <= -1.0_SHR_KIND_R8) then + h = pi + else if (cos_h >= 1.0_SHR_KIND_R8) then + h = 0.0_SHR_KIND_R8 + else + h = acos(cos_h) + end if + + !----------------------------------------------------------------------- + ! Define Local Time t and t + dt + + ! adjust t to be between -pi and pi + t1 = (jday - int(jday)) * twopi + lon - pi + + if (t1 >= pi) then + t1 = t1 - twopi + else if (t1 < -pi) then + t1 = t1 + twopi + end if + + dt = dt_avg / 86400.0_SHR_KIND_R8 * twopi + t2 = t1 + dt + + !----------------------------------------------------------------------- + ! Compute Cosine Solar Zenith angle + + ! define terms needed in the cosine zenith angle equation + aa = sin(lat) * sin(declin) + bb = cos(lat) * cos(declin) + + ! define the hour angle + ! force it to be between -h and h + ! consider the situation when the night period is too short + if (t2 >= pi .and. t1 <= pi .and. pi - h <= dt) then + tt2 = h + tt1 = min(max(t1, -h) , h) + tt4 = min(max(t2, twopi - h), twopi + h) + tt3 = twopi - h + else if (t2 >= -pi .and. t1 <= -pi .and. pi - h <= dt) then + tt2 = - twopi + h + tt1 = min(max(t1, -twopi - h), -twopi + h) + tt4 = min(max(t2, -h) , h) + tt3 = -h + else + if (t2 > pi) then + tt2 = min(max(t2 - twopi, -h), h) + else if (t2 < - pi) then + tt2 = min(max(t2 + twopi, -h), h) + else + tt2 = min(max(t2 , -h), h) + end if + if (t1 > pi) then + tt1 = min(max(t1 - twopi, -h), h) + else if (t1 < - pi) then + tt1 = min(max(t1 + twopi, -h), h) + else + tt1 = min(max(t1 , -h), h) + end if + tt4 = 0.0_SHR_KIND_R8 + tt3 = 0.0_SHR_KIND_R8 + end if + + ! perform a time integration to obtain cosz if desired + ! output is valid over the period from t to t + dt + if (tt2 > tt1 .or. tt4 > tt3) then + shr_orb_avg_cosz = (aa * (tt2 - tt1) + bb * (sin(tt2) - sin(tt1))) / dt + & + (aa * (tt4 - tt3) + bb * (sin(tt4) - sin(tt3))) / dt + else + shr_orb_avg_cosz = 0.0_SHR_KIND_R8 + end if + + end function shr_orb_avg_cosz + + !=============================================================================== + + SUBROUTINE shr_orb_params( iyear_AD , eccen , obliq , mvelp , & + & obliqr , lambm0 , mvelpp, log_print ) + + !------------------------------------------------------------------------------- + ! + ! Calculate earths orbital parameters using Dave Threshers formula which + ! came from Berger, Andre. 1978 "A Simple Algorithm to Compute Long-Term + ! Variations of Daily Insolation". Contribution 18, Institute of Astronomy + ! and Geophysics, Universite Catholique de Louvain, Louvain-la-Neuve, Belgium + ! + !------------------------------Code history------------------------------------- + ! + ! Original Author: Erik Kluzek + ! Date: Oct/97 + ! + !------------------------------------------------------------------------------- + + !----------------------------- Arguments ------------------------------------ + integer(SHR_KIND_IN),intent(in) :: iyear_AD ! Year to calculate orbit for + real (SHR_KIND_R8),intent(inout) :: eccen ! orbital eccentricity + real (SHR_KIND_R8),intent(inout) :: obliq ! obliquity in degrees + real (SHR_KIND_R8),intent(inout) :: mvelp ! moving vernal equinox long + real (SHR_KIND_R8),intent(out) :: obliqr ! Earths obliquity in rad + real (SHR_KIND_R8),intent(out) :: lambm0 ! Mean long of perihelion at + ! vernal equinox (radians) + real (SHR_KIND_R8),intent(out) :: mvelpp ! moving vernal equinox long + ! of perihelion plus pi (rad) + logical ,intent(in) :: log_print ! Flags print of status/error + + !------------------------------ Parameters ---------------------------------- + integer(SHR_KIND_IN),parameter :: poblen =47 ! # of elements in series wrt obliquity + integer(SHR_KIND_IN),parameter :: pecclen=19 ! # of elements in series wrt eccentricity + integer(SHR_KIND_IN),parameter :: pmvelen=78 ! # of elements in series wrt vernal equinox + real (SHR_KIND_R8),parameter :: psecdeg = 1.0_SHR_KIND_R8/3600.0_SHR_KIND_R8 ! arc sec to deg conversion + + real (SHR_KIND_R8) :: degrad = pi/180._SHR_KIND_R8 ! degree to radian conversion factor + real (SHR_KIND_R8) :: yb4_1950AD ! number of years before 1950 AD + + character(len=*),parameter :: subname = '(shr_orb_params)' + + ! Cosine series data for computation of obliquity: amplitude (arc seconds), + ! rate (arc seconds/year), phase (degrees). + + real (SHR_KIND_R8), parameter :: obamp(poblen) = & ! amplitudes for obliquity cos series + & (/ -2462.2214466_SHR_KIND_R8, -857.3232075_SHR_KIND_R8, -629.3231835_SHR_KIND_R8, & + & -414.2804924_SHR_KIND_R8, -311.7632587_SHR_KIND_R8, 308.9408604_SHR_KIND_R8, & + & -162.5533601_SHR_KIND_R8, -116.1077911_SHR_KIND_R8, 101.1189923_SHR_KIND_R8, & + & -67.6856209_SHR_KIND_R8, 24.9079067_SHR_KIND_R8, 22.5811241_SHR_KIND_R8, & + & -21.1648355_SHR_KIND_R8, -15.6549876_SHR_KIND_R8, 15.3936813_SHR_KIND_R8, & + & 14.6660938_SHR_KIND_R8, -11.7273029_SHR_KIND_R8, 10.2742696_SHR_KIND_R8, & + & 6.4914588_SHR_KIND_R8, 5.8539148_SHR_KIND_R8, -5.4872205_SHR_KIND_R8, & + & -5.4290191_SHR_KIND_R8, 5.1609570_SHR_KIND_R8, 5.0786314_SHR_KIND_R8, & + & -4.0735782_SHR_KIND_R8, 3.7227167_SHR_KIND_R8, 3.3971932_SHR_KIND_R8, & + & -2.8347004_SHR_KIND_R8, -2.6550721_SHR_KIND_R8, -2.5717867_SHR_KIND_R8, & + & -2.4712188_SHR_KIND_R8, 2.4625410_SHR_KIND_R8, 2.2464112_SHR_KIND_R8, & + & -2.0755511_SHR_KIND_R8, -1.9713669_SHR_KIND_R8, -1.8813061_SHR_KIND_R8, & + & -1.8468785_SHR_KIND_R8, 1.8186742_SHR_KIND_R8, 1.7601888_SHR_KIND_R8, & + & -1.5428851_SHR_KIND_R8, 1.4738838_SHR_KIND_R8, -1.4593669_SHR_KIND_R8, & + & 1.4192259_SHR_KIND_R8, -1.1818980_SHR_KIND_R8, 1.1756474_SHR_KIND_R8, & + & -1.1316126_SHR_KIND_R8, 1.0896928_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: obrate(poblen) = & ! rates for obliquity cosine series + & (/ 31.609974_SHR_KIND_R8, 32.620504_SHR_KIND_R8, 24.172203_SHR_KIND_R8, & + & 31.983787_SHR_KIND_R8, 44.828336_SHR_KIND_R8, 30.973257_SHR_KIND_R8, & + & 43.668246_SHR_KIND_R8, 32.246691_SHR_KIND_R8, 30.599444_SHR_KIND_R8, & + & 42.681324_SHR_KIND_R8, 43.836462_SHR_KIND_R8, 47.439436_SHR_KIND_R8, & + & 63.219948_SHR_KIND_R8, 64.230478_SHR_KIND_R8, 1.010530_SHR_KIND_R8, & + & 7.437771_SHR_KIND_R8, 55.782177_SHR_KIND_R8, 0.373813_SHR_KIND_R8, & + & 13.218362_SHR_KIND_R8, 62.583231_SHR_KIND_R8, 63.593761_SHR_KIND_R8, & + & 76.438310_SHR_KIND_R8, 45.815258_SHR_KIND_R8, 8.448301_SHR_KIND_R8, & + & 56.792707_SHR_KIND_R8, 49.747842_SHR_KIND_R8, 12.058272_SHR_KIND_R8, & + & 75.278220_SHR_KIND_R8, 65.241008_SHR_KIND_R8, 64.604291_SHR_KIND_R8, & + & 1.647247_SHR_KIND_R8, 7.811584_SHR_KIND_R8, 12.207832_SHR_KIND_R8, & + & 63.856665_SHR_KIND_R8, 56.155990_SHR_KIND_R8, 77.448840_SHR_KIND_R8, & + & 6.801054_SHR_KIND_R8, 62.209418_SHR_KIND_R8, 20.656133_SHR_KIND_R8, & + & 48.344406_SHR_KIND_R8, 55.145460_SHR_KIND_R8, 69.000539_SHR_KIND_R8, & + & 11.071350_SHR_KIND_R8, 74.291298_SHR_KIND_R8, 11.047742_SHR_KIND_R8, & + & 0.636717_SHR_KIND_R8, 12.844549_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: obphas(poblen) = & ! phases for obliquity cosine series + & (/ 251.9025_SHR_KIND_R8, 280.8325_SHR_KIND_R8, 128.3057_SHR_KIND_R8, & + & 292.7252_SHR_KIND_R8, 15.3747_SHR_KIND_R8, 263.7951_SHR_KIND_R8, & + & 308.4258_SHR_KIND_R8, 240.0099_SHR_KIND_R8, 222.9725_SHR_KIND_R8, & + & 268.7809_SHR_KIND_R8, 316.7998_SHR_KIND_R8, 319.6024_SHR_KIND_R8, & + & 143.8050_SHR_KIND_R8, 172.7351_SHR_KIND_R8, 28.9300_SHR_KIND_R8, & + & 123.5968_SHR_KIND_R8, 20.2082_SHR_KIND_R8, 40.8226_SHR_KIND_R8, & + & 123.4722_SHR_KIND_R8, 155.6977_SHR_KIND_R8, 184.6277_SHR_KIND_R8, & + & 267.2772_SHR_KIND_R8, 55.0196_SHR_KIND_R8, 152.5268_SHR_KIND_R8, & + & 49.1382_SHR_KIND_R8, 204.6609_SHR_KIND_R8, 56.5233_SHR_KIND_R8, & + & 200.3284_SHR_KIND_R8, 201.6651_SHR_KIND_R8, 213.5577_SHR_KIND_R8, & + & 17.0374_SHR_KIND_R8, 164.4194_SHR_KIND_R8, 94.5422_SHR_KIND_R8, & + & 131.9124_SHR_KIND_R8, 61.0309_SHR_KIND_R8, 296.2073_SHR_KIND_R8, & + & 135.4894_SHR_KIND_R8, 114.8750_SHR_KIND_R8, 247.0691_SHR_KIND_R8, & + & 256.6114_SHR_KIND_R8, 32.1008_SHR_KIND_R8, 143.6804_SHR_KIND_R8, & + & 16.8784_SHR_KIND_R8, 160.6835_SHR_KIND_R8, 27.5932_SHR_KIND_R8, & + & 348.1074_SHR_KIND_R8, 82.6496_SHR_KIND_R8/) + + ! Cosine/sine series data for computation of eccentricity and fixed vernal + ! equinox longitude of perihelion (fvelp): amplitude, + ! rate (arc seconds/year), phase (degrees). + + real (SHR_KIND_R8), parameter :: ecamp (pecclen) = & ! ampl for eccen/fvelp cos/sin series + & (/ 0.01860798_SHR_KIND_R8, 0.01627522_SHR_KIND_R8, -0.01300660_SHR_KIND_R8, & + & 0.00988829_SHR_KIND_R8, -0.00336700_SHR_KIND_R8, 0.00333077_SHR_KIND_R8, & + & -0.00235400_SHR_KIND_R8, 0.00140015_SHR_KIND_R8, 0.00100700_SHR_KIND_R8, & + & 0.00085700_SHR_KIND_R8, 0.00064990_SHR_KIND_R8, 0.00059900_SHR_KIND_R8, & + & 0.00037800_SHR_KIND_R8, -0.00033700_SHR_KIND_R8, 0.00027600_SHR_KIND_R8, & + & 0.00018200_SHR_KIND_R8, -0.00017400_SHR_KIND_R8, -0.00012400_SHR_KIND_R8, & + & 0.00001250_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: ecrate(pecclen) = & ! rates for eccen/fvelp cos/sin series + & (/ 4.2072050_SHR_KIND_R8, 7.3460910_SHR_KIND_R8, 17.8572630_SHR_KIND_R8, & + & 17.2205460_SHR_KIND_R8, 16.8467330_SHR_KIND_R8, 5.1990790_SHR_KIND_R8, & + & 18.2310760_SHR_KIND_R8, 26.2167580_SHR_KIND_R8, 6.3591690_SHR_KIND_R8, & + & 16.2100160_SHR_KIND_R8, 3.0651810_SHR_KIND_R8, 16.5838290_SHR_KIND_R8, & + & 18.4939800_SHR_KIND_R8, 6.1909530_SHR_KIND_R8, 18.8677930_SHR_KIND_R8, & + & 17.4255670_SHR_KIND_R8, 6.1860010_SHR_KIND_R8, 18.4174410_SHR_KIND_R8, & + & 0.6678630_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: ecphas(pecclen) = & ! phases for eccen/fvelp cos/sin series + & (/ 28.620089_SHR_KIND_R8, 193.788772_SHR_KIND_R8, 308.307024_SHR_KIND_R8, & + & 320.199637_SHR_KIND_R8, 279.376984_SHR_KIND_R8, 87.195000_SHR_KIND_R8, & + & 349.129677_SHR_KIND_R8, 128.443387_SHR_KIND_R8, 154.143880_SHR_KIND_R8, & + & 291.269597_SHR_KIND_R8, 114.860583_SHR_KIND_R8, 332.092251_SHR_KIND_R8, & + & 296.414411_SHR_KIND_R8, 145.769910_SHR_KIND_R8, 337.237063_SHR_KIND_R8, & + & 152.092288_SHR_KIND_R8, 126.839891_SHR_KIND_R8, 210.667199_SHR_KIND_R8, & + & 72.108838_SHR_KIND_R8/) + + ! Sine series data for computation of moving vernal equinox longitude of + ! perihelion: amplitude (arc seconds), rate (arc sec/year), phase (degrees). + + real (SHR_KIND_R8), parameter :: mvamp (pmvelen) = & ! amplitudes for mvelp sine series + & (/ 7391.0225890_SHR_KIND_R8, 2555.1526947_SHR_KIND_R8, 2022.7629188_SHR_KIND_R8, & + & -1973.6517951_SHR_KIND_R8, 1240.2321818_SHR_KIND_R8, 953.8679112_SHR_KIND_R8, & + & -931.7537108_SHR_KIND_R8, 872.3795383_SHR_KIND_R8, 606.3544732_SHR_KIND_R8, & + & -496.0274038_SHR_KIND_R8, 456.9608039_SHR_KIND_R8, 346.9462320_SHR_KIND_R8, & + & -305.8412902_SHR_KIND_R8, 249.6173246_SHR_KIND_R8, -199.1027200_SHR_KIND_R8, & + & 191.0560889_SHR_KIND_R8, -175.2936572_SHR_KIND_R8, 165.9068833_SHR_KIND_R8, & + & 161.1285917_SHR_KIND_R8, 139.7878093_SHR_KIND_R8, -133.5228399_SHR_KIND_R8, & + & 117.0673811_SHR_KIND_R8, 104.6907281_SHR_KIND_R8, 95.3227476_SHR_KIND_R8, & + & 86.7824524_SHR_KIND_R8, 86.0857729_SHR_KIND_R8, 70.5893698_SHR_KIND_R8, & + & -69.9719343_SHR_KIND_R8, -62.5817473_SHR_KIND_R8, 61.5450059_SHR_KIND_R8, & + & -57.9364011_SHR_KIND_R8, 57.1899832_SHR_KIND_R8, -57.0236109_SHR_KIND_R8, & + & -54.2119253_SHR_KIND_R8, 53.2834147_SHR_KIND_R8, 52.1223575_SHR_KIND_R8, & + & -49.0059908_SHR_KIND_R8, -48.3118757_SHR_KIND_R8, -45.4191685_SHR_KIND_R8, & + & -42.2357920_SHR_KIND_R8, -34.7971099_SHR_KIND_R8, 34.4623613_SHR_KIND_R8, & + & -33.8356643_SHR_KIND_R8, 33.6689362_SHR_KIND_R8, -31.2521586_SHR_KIND_R8, & + & -30.8798701_SHR_KIND_R8, 28.4640769_SHR_KIND_R8, -27.1960802_SHR_KIND_R8, & + & 27.0860736_SHR_KIND_R8, -26.3437456_SHR_KIND_R8, 24.7253740_SHR_KIND_R8, & + & 24.6732126_SHR_KIND_R8, 24.4272733_SHR_KIND_R8, 24.0127327_SHR_KIND_R8, & + & 21.7150294_SHR_KIND_R8, -21.5375347_SHR_KIND_R8, 18.1148363_SHR_KIND_R8, & + & -16.9603104_SHR_KIND_R8, -16.1765215_SHR_KIND_R8, 15.5567653_SHR_KIND_R8, & + & 15.4846529_SHR_KIND_R8, 15.2150632_SHR_KIND_R8, 14.5047426_SHR_KIND_R8, & + & -14.3873316_SHR_KIND_R8, 13.1351419_SHR_KIND_R8, 12.8776311_SHR_KIND_R8, & + & 11.9867234_SHR_KIND_R8, 11.9385578_SHR_KIND_R8, 11.7030822_SHR_KIND_R8, & + & 11.6018181_SHR_KIND_R8, -11.2617293_SHR_KIND_R8, -10.4664199_SHR_KIND_R8, & + & 10.4333970_SHR_KIND_R8, -10.2377466_SHR_KIND_R8, 10.1934446_SHR_KIND_R8, & + & -10.1280191_SHR_KIND_R8, 10.0289441_SHR_KIND_R8, -10.0034259_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: mvrate(pmvelen) = & ! rates for mvelp sine series + & (/ 31.609974_SHR_KIND_R8, 32.620504_SHR_KIND_R8, 24.172203_SHR_KIND_R8, & + & 0.636717_SHR_KIND_R8, 31.983787_SHR_KIND_R8, 3.138886_SHR_KIND_R8, & + & 30.973257_SHR_KIND_R8, 44.828336_SHR_KIND_R8, 0.991874_SHR_KIND_R8, & + & 0.373813_SHR_KIND_R8, 43.668246_SHR_KIND_R8, 32.246691_SHR_KIND_R8, & + & 30.599444_SHR_KIND_R8, 2.147012_SHR_KIND_R8, 10.511172_SHR_KIND_R8, & + & 42.681324_SHR_KIND_R8, 13.650058_SHR_KIND_R8, 0.986922_SHR_KIND_R8, & + & 9.874455_SHR_KIND_R8, 13.013341_SHR_KIND_R8, 0.262904_SHR_KIND_R8, & + & 0.004952_SHR_KIND_R8, 1.142024_SHR_KIND_R8, 63.219948_SHR_KIND_R8, & + & 0.205021_SHR_KIND_R8, 2.151964_SHR_KIND_R8, 64.230478_SHR_KIND_R8, & + & 43.836462_SHR_KIND_R8, 47.439436_SHR_KIND_R8, 1.384343_SHR_KIND_R8, & + & 7.437771_SHR_KIND_R8, 18.829299_SHR_KIND_R8, 9.500642_SHR_KIND_R8, & + & 0.431696_SHR_KIND_R8, 1.160090_SHR_KIND_R8, 55.782177_SHR_KIND_R8, & + & 12.639528_SHR_KIND_R8, 1.155138_SHR_KIND_R8, 0.168216_SHR_KIND_R8, & + & 1.647247_SHR_KIND_R8, 10.884985_SHR_KIND_R8, 5.610937_SHR_KIND_R8, & + & 12.658184_SHR_KIND_R8, 1.010530_SHR_KIND_R8, 1.983748_SHR_KIND_R8, & + & 14.023871_SHR_KIND_R8, 0.560178_SHR_KIND_R8, 1.273434_SHR_KIND_R8, & + & 12.021467_SHR_KIND_R8, 62.583231_SHR_KIND_R8, 63.593761_SHR_KIND_R8, & + & 76.438310_SHR_KIND_R8, 4.280910_SHR_KIND_R8, 13.218362_SHR_KIND_R8, & + & 17.818769_SHR_KIND_R8, 8.359495_SHR_KIND_R8, 56.792707_SHR_KIND_R8, & + & 8.448301_SHR_KIND_R8, 1.978796_SHR_KIND_R8, 8.863925_SHR_KIND_R8, & + & 0.186365_SHR_KIND_R8, 8.996212_SHR_KIND_R8, 6.771027_SHR_KIND_R8, & + & 45.815258_SHR_KIND_R8, 12.002811_SHR_KIND_R8, 75.278220_SHR_KIND_R8, & + & 65.241008_SHR_KIND_R8, 18.870667_SHR_KIND_R8, 22.009553_SHR_KIND_R8, & + & 64.604291_SHR_KIND_R8, 11.498094_SHR_KIND_R8, 0.578834_SHR_KIND_R8, & + & 9.237738_SHR_KIND_R8, 49.747842_SHR_KIND_R8, 2.147012_SHR_KIND_R8, & + & 1.196895_SHR_KIND_R8, 2.133898_SHR_KIND_R8, 0.173168_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: mvphas(pmvelen) = & ! phases for mvelp sine series + & (/ 251.9025_SHR_KIND_R8, 280.8325_SHR_KIND_R8, 128.3057_SHR_KIND_R8, & + & 348.1074_SHR_KIND_R8, 292.7252_SHR_KIND_R8, 165.1686_SHR_KIND_R8, & + & 263.7951_SHR_KIND_R8, 15.3747_SHR_KIND_R8, 58.5749_SHR_KIND_R8, & + & 40.8226_SHR_KIND_R8, 308.4258_SHR_KIND_R8, 240.0099_SHR_KIND_R8, & + & 222.9725_SHR_KIND_R8, 106.5937_SHR_KIND_R8, 114.5182_SHR_KIND_R8, & + & 268.7809_SHR_KIND_R8, 279.6869_SHR_KIND_R8, 39.6448_SHR_KIND_R8, & + & 126.4108_SHR_KIND_R8, 291.5795_SHR_KIND_R8, 307.2848_SHR_KIND_R8, & + & 18.9300_SHR_KIND_R8, 273.7596_SHR_KIND_R8, 143.8050_SHR_KIND_R8, & + & 191.8927_SHR_KIND_R8, 125.5237_SHR_KIND_R8, 172.7351_SHR_KIND_R8, & + & 316.7998_SHR_KIND_R8, 319.6024_SHR_KIND_R8, 69.7526_SHR_KIND_R8, & + & 123.5968_SHR_KIND_R8, 217.6432_SHR_KIND_R8, 85.5882_SHR_KIND_R8, & + & 156.2147_SHR_KIND_R8, 66.9489_SHR_KIND_R8, 20.2082_SHR_KIND_R8, & + & 250.7568_SHR_KIND_R8, 48.0188_SHR_KIND_R8, 8.3739_SHR_KIND_R8, & + & 17.0374_SHR_KIND_R8, 155.3409_SHR_KIND_R8, 94.1709_SHR_KIND_R8, & + & 221.1120_SHR_KIND_R8, 28.9300_SHR_KIND_R8, 117.1498_SHR_KIND_R8, & + & 320.5095_SHR_KIND_R8, 262.3602_SHR_KIND_R8, 336.2148_SHR_KIND_R8, & + & 233.0046_SHR_KIND_R8, 155.6977_SHR_KIND_R8, 184.6277_SHR_KIND_R8, & + & 267.2772_SHR_KIND_R8, 78.9281_SHR_KIND_R8, 123.4722_SHR_KIND_R8, & + & 188.7132_SHR_KIND_R8, 180.1364_SHR_KIND_R8, 49.1382_SHR_KIND_R8, & + & 152.5268_SHR_KIND_R8, 98.2198_SHR_KIND_R8, 97.4808_SHR_KIND_R8, & + & 221.5376_SHR_KIND_R8, 168.2438_SHR_KIND_R8, 161.1199_SHR_KIND_R8, & + & 55.0196_SHR_KIND_R8, 262.6495_SHR_KIND_R8, 200.3284_SHR_KIND_R8, & + & 201.6651_SHR_KIND_R8, 294.6547_SHR_KIND_R8, 99.8233_SHR_KIND_R8, & + & 213.5577_SHR_KIND_R8, 154.1631_SHR_KIND_R8, 232.7153_SHR_KIND_R8, & + & 138.3034_SHR_KIND_R8, 204.6609_SHR_KIND_R8, 106.5938_SHR_KIND_R8, & + & 250.4676_SHR_KIND_R8, 332.3345_SHR_KIND_R8, 27.3039_SHR_KIND_R8/) + + !---------------------------Local variables---------------------------------- + integer(SHR_KIND_IN) :: i ! Index for series summations + real (SHR_KIND_R8) :: obsum ! Obliquity series summation + real (SHR_KIND_R8) :: cossum ! Cos series summation for eccentricity/fvelp + real (SHR_KIND_R8) :: sinsum ! Sin series summation for eccentricity/fvelp + real (SHR_KIND_R8) :: fvelp ! Fixed vernal equinox long of perihelion + real (SHR_KIND_R8) :: mvsum ! mvelp series summation + real (SHR_KIND_R8) :: beta ! Intermediate argument for lambm0 + real (SHR_KIND_R8) :: years ! Years to time of interest ( pos <=> future) + real (SHR_KIND_R8) :: eccen2 ! eccentricity squared + real (SHR_KIND_R8) :: eccen3 ! eccentricity cubed + integer :: s_logunit + !-------------------------- Formats ----------------------------------------- + character(len=*),parameter :: F00 = "('(shr_orb_params) ',4a)" + character(len=*),parameter :: F01 = "('(shr_orb_params) ',a,i9)" + character(len=*),parameter :: F02 = "('(shr_orb_params) ',a,f6.3)" + character(len=*),parameter :: F03 = "('(shr_orb_params) ',a,es14.6)" + + !---------------------------------------------------------------------------- + ! radinp and algorithms below will need a degree to radian conversion factor + call shr_log_getLogUnit(s_logunit) + if ( log_print ) then + write(s_logunit,F00) 'Calculate characteristics of the orbit:' + end if + + ! Check for flag to use input orbit parameters + + IF ( iyear_AD == SHR_ORB_UNDEF_INT ) THEN + + ! Check input obliq, eccen, and mvelp to ensure reasonable + + if( obliq == SHR_ORB_UNDEF_REAL )then + write(s_logunit,F00) trim(subname)//' Have to specify orbital parameters:' + write(s_logunit,F00) 'Either set: iyear_AD, OR [obliq, eccen, and mvelp]:' + write(s_logunit,F00) 'iyear_AD is the year to simulate orbit for (ie. 1950): ' + write(s_logunit,F00) 'obliq, eccen, mvelp specify the orbit directly:' + write(s_logunit,F00) 'The AMIP II settings (for a 1995 orbit) are: ' + write(s_logunit,F00) ' obliq = 23.4441' + write(s_logunit,F00) ' eccen = 0.016715' + write(s_logunit,F00) ' mvelp = 102.7' + call shr_sys_abort(subname//' ERROR: unreasonable obliq') + else if ( log_print ) then + write(s_logunit,F00) 'Use input orbital parameters: ' + end if + if( (obliq < SHR_ORB_OBLIQ_MIN).or.(obliq > SHR_ORB_OBLIQ_MAX) ) then + write(s_logunit,F03) 'Input obliquity unreasonable: ', obliq + call shr_sys_abort(subname//' ERROR: unreasonable obliq') + end if + if( (eccen < SHR_ORB_ECCEN_MIN).or.(eccen > SHR_ORB_ECCEN_MAX) ) then + write(s_logunit,F03) 'Input eccentricity unreasonable: ', eccen + call shr_sys_abort(subname//' ERROR: unreasonable eccen') + end if + if( (mvelp < SHR_ORB_MVELP_MIN).or.(mvelp > SHR_ORB_MVELP_MAX) ) then + write(s_logunit,F03) 'Input mvelp unreasonable: ' , mvelp + call shr_sys_abort(subname//' ERROR: unreasonable mvelp') + end if + eccen2 = eccen*eccen + eccen3 = eccen2*eccen + + ELSE ! Otherwise calculate based on years before present + + if ( log_print ) then + write(s_logunit,F01) 'Calculate orbit for year: ' , iyear_AD + end if + yb4_1950AD = 1950.0_SHR_KIND_R8 - real(iyear_AD,SHR_KIND_R8) + if ( abs(yb4_1950AD) .gt. 1000000.0_SHR_KIND_R8 )then + write(s_logunit,F00) 'orbit only valid for years+-1000000' + write(s_logunit,F00) 'Relative to 1950 AD' + write(s_logunit,F03) '# of years before 1950: ',yb4_1950AD + write(s_logunit,F01) 'Year to simulate was : ',iyear_AD + call shr_sys_abort(subname//' ERROR: unreasonable year') + end if + + ! The following calculates the earths obliquity, orbital eccentricity + ! (and various powers of it) and vernal equinox mean longitude of + ! perihelion for years in the past (future = negative of years past), + ! using constants (see parameter section) given in the program of: + ! + ! Berger, Andre. 1978 A Simple Algorithm to Compute Long-Term Variations + ! of Daily Insolation. Contribution 18, Institute of Astronomy and + ! Geophysics, Universite Catholique de Louvain, Louvain-la-Neuve, Belgium. + ! + ! and formulas given in the paper (where less precise constants are also + ! given): + ! + ! Berger, Andre. 1978. Long-Term Variations of Daily Insolation and + ! Quaternary Climatic Changes. J. of the Atmo. Sci. 35:2362-2367 + ! + ! The algorithm is valid only to 1,000,000 years past or hence. + ! For a solution valid to 5-10 million years past see the above author. + ! Algorithm below is better for years closer to present than is the + ! 5-10 million year solution. + ! + ! Years to time of interest must be negative of years before present + ! (1950) in formulas that follow. + + years = - yb4_1950AD + + ! In the summations below, cosine or sine arguments, which end up in + ! degrees, must be converted to radians via multiplication by degrad. + ! + ! Summation of cosine series for obliquity (epsilon in Berger 1978) in + ! degrees. Convert the amplitudes and rates, which are in arc secs, into + ! degrees via multiplication by psecdeg (arc seconds to degrees conversion + ! factor). For obliq, first term is Berger 1978 epsilon star; second + ! term is series summation in degrees. + + obsum = 0.0_SHR_KIND_R8 + do i = 1, poblen + obsum = obsum + obamp(i)*psecdeg*cos((obrate(i)*psecdeg*years + & + & obphas(i))*degrad) + end do + obliq = 23.320556_SHR_KIND_R8 + obsum + + ! Summation of cosine and sine series for computation of eccentricity + ! (eccen; e in Berger 1978) and fixed vernal equinox longitude of + ! perihelion (fvelp; pi in Berger 1978), which is used for computation + ! of moving vernal equinox longitude of perihelion. Convert the rates, + ! which are in arc seconds, into degrees via multiplication by psecdeg. + + cossum = 0.0_SHR_KIND_R8 + do i = 1, pecclen + cossum = cossum+ecamp(i)*cos((ecrate(i)*psecdeg*years+ecphas(i))*degrad) + end do + + sinsum = 0.0_SHR_KIND_R8 + do i = 1, pecclen + sinsum = sinsum+ecamp(i)*sin((ecrate(i)*psecdeg*years+ecphas(i))*degrad) + end do + + ! Use summations to calculate eccentricity + + eccen2 = cossum*cossum + sinsum*sinsum + eccen = sqrt(eccen2) + eccen3 = eccen2*eccen + + ! A series of cases for fvelp, which is in radians. + if (abs(cossum) .le. 1.0E-8_SHR_KIND_R8) then + if (sinsum .eq. 0.0_SHR_KIND_R8) then + fvelp = 0.0_SHR_KIND_R8 + else if (sinsum .lt. 0.0_SHR_KIND_R8) then + fvelp = 1.5_SHR_KIND_R8*pi + else if (sinsum .gt. 0.0_SHR_KIND_R8) then + fvelp = .5_SHR_KIND_R8*pi + endif + else if (cossum .lt. 0.0_SHR_KIND_R8) then + fvelp = atan(sinsum/cossum) + pi + else ! cossum > 1.0e-8 + if (sinsum .lt. 0.0_SHR_KIND_R8) then + fvelp = atan(sinsum/cossum) + 2.0_SHR_KIND_R8*pi + else + fvelp = atan(sinsum/cossum) + endif + endif + + ! Summation of sin series for computation of moving vernal equinox long + ! of perihelion (mvelp; omega bar in Berger 1978) in degrees. For mvelp, + ! first term is fvelp in degrees; second term is Berger 1978 psi bar + ! times years and in degrees; third term is Berger 1978 zeta; fourth + ! term is series summation in degrees. Convert the amplitudes and rates, + ! which are in arc seconds, into degrees via multiplication by psecdeg. + ! Series summation plus second and third terms constitute Berger 1978 + ! psi, which is the general precession. + + mvsum = 0.0_SHR_KIND_R8 + do i = 1, pmvelen + mvsum = mvsum + mvamp(i)*psecdeg*sin((mvrate(i)*psecdeg*years + & + & mvphas(i))*degrad) + end do + mvelp = fvelp/degrad + 50.439273_SHR_KIND_R8*psecdeg*years + 3.392506_SHR_KIND_R8 + mvsum + + ! Cases to make sure mvelp is between 0 and 360. + + do while (mvelp .lt. 0.0_SHR_KIND_R8) + mvelp = mvelp + 360.0_SHR_KIND_R8 + end do + do while (mvelp .ge. 360.0_SHR_KIND_R8) + mvelp = mvelp - 360.0_SHR_KIND_R8 + end do + + END IF ! end of test on whether to calculate or use input orbital params + + ! Orbit needs the obliquity in radians + + obliqr = obliq*degrad + + ! 180 degrees must be added to mvelp since observations are made from the + ! earth and the sun is considered (wrongly for the algorithm) to go around + ! the earth. For a more graphic explanation see Appendix B in: + ! + ! A. Berger, M. Loutre and C. Tricot. 1993. Insolation and Earth Orbital + ! Periods. J. of Geophysical Research 98:10,341-10,362. + ! + ! Additionally, orbit will need this value in radians. So mvelp becomes + ! mvelpp (mvelp plus pi) + + mvelpp = (mvelp + 180._SHR_KIND_R8)*degrad + + ! Set up an argument used several times in lambm0 calculation ahead. + + beta = sqrt(1._SHR_KIND_R8 - eccen2) + + ! The mean longitude at the vernal equinox (lambda m nought in Berger + ! 1978; in radians) is calculated from the following formula given in + ! Berger 1978. At the vernal equinox the true longitude (lambda in Berger + ! 1978) is 0. + + lambm0 = 2._SHR_KIND_R8*((.5_SHR_KIND_R8*eccen + .125_SHR_KIND_R8*eccen3)*(1._SHR_KIND_R8 + beta)*sin(mvelpp) & + & - .250_SHR_KIND_R8*eccen2*(.5_SHR_KIND_R8 + beta)*sin(2._SHR_KIND_R8*mvelpp) & + & + .125_SHR_KIND_R8*eccen3*(1._SHR_KIND_R8/3._SHR_KIND_R8 + beta)*sin(3._SHR_KIND_R8*mvelpp)) + + if ( log_print ) then + write(s_logunit,F03) '------ Computed Orbital Parameters ------' + write(s_logunit,F03) 'Eccentricity = ',eccen + write(s_logunit,F03) 'Obliquity (deg) = ',obliq + write(s_logunit,F03) 'Obliquity (rad) = ',obliqr + write(s_logunit,F03) 'Long of perh(deg) = ',mvelp + write(s_logunit,F03) 'Long of perh(rad) = ',mvelpp + write(s_logunit,F03) 'Long at v.e.(rad) = ',lambm0 + write(s_logunit,F03) '-----------------------------------------' + end if + + END SUBROUTINE shr_orb_params + + !=============================================================================== + + SUBROUTINE shr_orb_decl(calday ,eccen ,mvelpp ,lambm0 ,obliqr ,delta ,eccf) + + !------------------------------------------------------------------------------- + ! + ! Compute earth/orbit parameters using formula suggested by + ! Duane Thresher. + ! + !---------------------------Code history---------------------------------------- + ! + ! Original version: Erik Kluzek + ! Date: Oct/1997 + ! + !------------------------------------------------------------------------------- + + !------------------------------Arguments-------------------------------- + real (SHR_KIND_R8),intent(in) :: calday ! Calendar day, including fraction + real (SHR_KIND_R8),intent(in) :: eccen ! Eccentricity + real (SHR_KIND_R8),intent(in) :: obliqr ! Earths obliquity in radians + real (SHR_KIND_R8),intent(in) :: lambm0 ! Mean long of perihelion at the + ! vernal equinox (radians) + real (SHR_KIND_R8),intent(in) :: mvelpp ! moving vernal equinox longitude + ! of perihelion plus pi (radians) + real (SHR_KIND_R8),intent(out) :: delta ! Solar declination angle in rad + real (SHR_KIND_R8),intent(out) :: eccf ! Earth-sun distance factor (ie. (1/r)**2) + + !---------------------------Local variables----------------------------- + real (SHR_KIND_R8),parameter :: dayspy = 365.0_SHR_KIND_R8 ! days per year + real (SHR_KIND_R8),parameter :: ve = 80.5_SHR_KIND_R8 ! Calday of vernal equinox + ! assumes Jan 1 = calday 1 + + real (SHR_KIND_R8) :: lambm ! Lambda m, mean long of perihelion (rad) + real (SHR_KIND_R8) :: lmm ! Intermediate argument involving lambm + real (SHR_KIND_R8) :: lamb ! Lambda, the earths long of perihelion + real (SHR_KIND_R8) :: invrho ! Inverse normalized sun/earth distance + real (SHR_KIND_R8) :: sinl ! Sine of lmm + ! Compute eccentricity factor and solar declination using + ! day value where a round day (such as 213.0) refers to 0z at + ! Greenwich longitude. + ! + ! Use formulas from Berger, Andre 1978: Long-Term Variations of Daily + ! Insolation and Quaternary Climatic Changes. J. of the Atmo. Sci. + ! 35:2362-2367. + ! + ! To get the earths true longitude (position in orbit; lambda in Berger + ! 1978) which is necessary to find the eccentricity factor and declination, + ! must first calculate the mean longitude (lambda m in Berger 1978) at + ! the present day. This is done by adding to lambm0 (the mean longitude + ! at the vernal equinox, set as March 21 at noon, when lambda=0; in radians) + ! an increment (delta lambda m in Berger 1978) that is the number of + ! days past or before (a negative increment) the vernal equinox divided by + ! the days in a model year times the 2*pi radians in a complete orbit. + + lambm = lambm0 + (calday - ve)*2._SHR_KIND_R8*pi/dayspy + lmm = lambm - mvelpp + + ! The earths true longitude, in radians, is then found from + ! the formula in Berger 1978: + + sinl = sin(lmm) + lamb = lambm + eccen*(2._SHR_KIND_R8*sinl + eccen*(1.25_SHR_KIND_R8*sin(2._SHR_KIND_R8*lmm) & + & + eccen*((13.0_SHR_KIND_R8/12.0_SHR_KIND_R8)*sin(3._SHR_KIND_R8*lmm) - 0.25_SHR_KIND_R8*sinl))) + + ! Using the obliquity, eccentricity, moving vernal equinox longitude of + ! perihelion (plus), and earths true longitude, the declination (delta) + ! and the normalized earth/sun distance (rho in Berger 1978; actually inverse + ! rho will be used), and thus the eccentricity factor (eccf), can be + ! calculated from formulas given in Berger 1978. + + invrho = (1._SHR_KIND_R8 + eccen*cos(lamb - mvelpp)) / (1._SHR_KIND_R8 - eccen*eccen) + + ! Set solar declination and eccentricity factor + + delta = asin(sin(obliqr)*sin(lamb)) + eccf = invrho*invrho + + return + + END SUBROUTINE shr_orb_decl + + !=============================================================================== + + SUBROUTINE shr_orb_print( iyear_AD, eccen, obliq, mvelp ) + + !------------------------------------------------------------------------------- + ! + ! Print out the information on the Earths input orbital characteristics + ! + !---------------------------Code history---------------------------------------- + ! + ! Original version: Erik Kluzek + ! Date: Oct/1997 + ! + !------------------------------------------------------------------------------- + + !---------------------------Arguments---------------------------------------- + integer(SHR_KIND_IN),intent(in) :: iyear_AD ! requested Year (AD) + real (SHR_KIND_R8),intent(in) :: eccen ! eccentricity (unitless) + ! (typically 0 to 0.1) + real (SHR_KIND_R8),intent(in) :: obliq ! obliquity (-90 to +90 degrees) + ! typically 22-26 + real (SHR_KIND_R8),intent(in) :: mvelp ! moving vernal equinox at perhel + ! (0 to 360 degrees) + integer :: s_logunit + logical :: debug = .false. + !-------------------------- Formats ----------------------------------------- + character(len=*),parameter :: F00 = "('(shr_orb_print) ',4a)" + character(len=*),parameter :: F01 = "('(shr_orb_print) ',a,i9.4)" + character(len=*),parameter :: F02 = "('(shr_orb_print) ',a,f6.3)" + character(len=*),parameter :: F03 = "('(shr_orb_print) ',a,es14.6)" + !---------------------------------------------------------------------------- +#ifdef DEBUG + debug = .true. +#endif + call shr_log_getLogUnit(s_logunit) + if(s_logunit .ne. 6 .or. debug) then + if ( iyear_AD .ne. SHR_ORB_UNDEF_INT ) then + if ( iyear_AD > 0 ) then + write(s_logunit,F01) 'Orbital parameters calculated for year: AD ',iyear_AD + else + write(s_logunit,F01) 'Orbital parameters calculated for year: BC ',iyear_AD + end if + else if ( obliq /= SHR_ORB_UNDEF_REAL ) then + write(s_logunit,F03) 'Orbital parameters: ' + write(s_logunit,F03) 'Obliquity (degree): ', obliq + write(s_logunit,F03) 'Eccentricity (unitless): ', eccen + write(s_logunit,F03) 'Long. of moving Perhelion (deg): ', mvelp + else + write(s_logunit,F03) 'Orbit parameters not set!' + end if + endif + + END SUBROUTINE shr_orb_print + !=============================================================================== + +END MODULE shr_orb_mod diff --git a/shared/shr_strconvert_mod.F90 b/shared/shr_strconvert_mod.F90 new file mode 100644 index 000000000..413f23145 --- /dev/null +++ b/shared/shr_strconvert_mod.F90 @@ -0,0 +1,166 @@ +module shr_strconvert_mod + +! This module defines toString, a generic function for creating character type +! representations of data, as implemented for the most commonly used intrinsic +! types: +! +! - 4 and 8 byte integer +! - 4 and 8 byte real +! - logical +! +! No toString implementation is provided for character input, but this may be +! added if some use case arises. +! +! Currently, only scalar inputs are supported. The return type of this function +! is character with deferred (allocatable) length. +! +! The functions for integers and reals allow an optional format_string argument, +! which can be used to control the padding and precision of output as with any +! write statement. However, the implementations internally must use a +! preallocated buffer, so a format_string that significantly increases the size +! of the output may cause a run-time error or undefined behavior in the program. +! +! Other modules may want to provide extensions of toString for their own derived +! types. In this case there are two guidelines to observe: +! +! - It is preferable to have only one mandatory argument, which is the object to +! produce a string from. There may be other formatting options, but the +! implementation should do something sensible without these. +! +! - Since the main purpose of toString is to provide a human-readable +! representation of a type, especially for documentation or debugging +! purposes, refrain from printing large array components in their entirety +! (instead consider printing only the shape, or statistics such as +! min/mean/max for arrays of numbers). + +use shr_kind_mod, only: & + i4 => shr_kind_i4, & + i8 => shr_kind_i8, & + r4 => shr_kind_r4, & + r8 => shr_kind_r8, & + cs => shr_kind_cs + +use shr_infnan_mod, only: & + isnan => shr_infnan_isnan + +implicit none +private + +! Human-readable representation of data. +public :: toString + +interface toString + module procedure i4ToString + module procedure i8ToString + module procedure r4ToString + module procedure r8ToString + module procedure logicalToString +end interface toString + +contains + +pure function i4ToString(input, format_string) result(string) + integer(i4), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + ! For most compilers, these two statements are equivalent to a format of + ! '(I0)', but that's not technically in the standard. + write(buffer, '(I11)') input + buffer = adjustl(buffer) + end if + + allocate(string, source=trim(buffer)) + +end function i4ToString + +pure function i8ToString(input, format_string) result(string) + integer(i8), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + ! For most compilers, these two statements are equivalent to a format of + ! '(I0)', but that's not technically in the standard. + write(buffer, '(I20)') input + buffer = adjustl(buffer) + end if + + allocate(string, source=trim(buffer)) + +end function i8ToString + +pure function r4ToString(input, format_string) result(string) + real(r4), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + write(buffer, '(ES15.8 E2)') input + buffer = adjustl(buffer) + ! Deal with the fact that the "+" sign is optional by simply adding it if + ! it is not present, so that the default format is standardized across + ! compilers. + ! Assumes that compilers do not treat the sign bit on NaN values specially. + if (.not. isnan(input) .and. all(buffer(1:1) /= ["-", "+"])) then + buffer = "+" // trim(buffer) + end if + end if + + allocate(string, source=trim(buffer)) + +end function r4ToString + +pure function r8ToString(input, format_string) result(string) + real(r8), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + write(buffer, '(ES24.16 E3)') input + buffer = adjustl(buffer) + ! Deal with the fact that the "+" sign is optional by simply adding it if + ! it is not present, so that the default format is standardized across + ! compilers. + ! Assumes that compilers do not treat the sign bit on NaN values specially. + if (.not. isnan(input) .and. all(buffer(1:1) /= ["-", "+"])) then + buffer = "+" // trim(buffer) + end if + end if + + allocate(string, source=trim(buffer)) + +end function r8ToString + +pure function logicalToString(input) result(string) + logical, intent(in) :: input + character(len=:), allocatable :: string + + ! We could use a write statement, but this is easier. + allocate(character(len=1) :: string) + if (input) then + string = "T" + else + string = "F" + end if + +end function logicalToString + +end module shr_strconvert_mod diff --git a/shared/shr_sys_mod.F90 b/shared/shr_sys_mod.F90 new file mode 100644 index 000000000..389d45829 --- /dev/null +++ b/shared/shr_sys_mod.F90 @@ -0,0 +1,331 @@ +!=============================================================================== +! SVN $Id: shr_sys_mod.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_sys_mod.F90 $ +!=============================================================================== + +! Currently supported by all compilers +#define HAVE_GET_ENVIRONMENT +#define HAVE_SLEEP + +! Except this combination? +#if defined CPRPGI && defined CNL +#undef HAVE_GET_ENVIRONMENT +#endif + +#if defined CPRNAG +#define HAVE_EXECUTE +#endif + +MODULE shr_sys_mod + + use shr_kind_mod ! defines real & integer kinds + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + use shr_abort_mod, only: shr_sys_abort => shr_abort_abort + use shr_abort_mod, only: shr_sys_backtrace => shr_abort_backtrace + +#ifdef CPRNAG + ! NAG does not provide these as intrinsics, but it does provide modules + ! that implement commonly used POSIX routines. + use f90_unix_dir, only: chdir + use f90_unix_proc, only: abort, sleep +#endif + + implicit none + +! PUBLIC: Public interfaces + + private + + public :: shr_sys_system ! make a system call + public :: shr_sys_chdir ! change current working dir + public :: shr_sys_getenv ! get an environment variable + public :: shr_sys_irtc ! returns real-time clock tick + public :: shr_sys_sleep ! have program sleep for a while + public :: shr_sys_flush ! flush an i/o buffer + + ! Imported from shr_abort_mod and republished with renames. Other code that wishes to + ! use these routines should use these shr_sys names rather than directly using the + ! routines from shr_abort_abort. (This is for consistency with older code, from when + ! these routines were defined in shr_sys_mod.) + public :: shr_sys_abort ! abort a program + public :: shr_sys_backtrace ! print a backtrace, if possible + +!=============================================================================== +CONTAINS +!=============================================================================== + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_system(str,rcode) + + IMPLICIT none + + !----- arguments --- + character(*) ,intent(in) :: str ! system/shell command string + integer(SHR_KIND_IN),intent(out) :: rcode ! function return error code + + !----- functions ----- +#if (defined LINUX && !defined CPRGNU) + integer(SHR_KIND_IN),external :: system ! function to envoke shell command +#endif + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_system) ' + character(*),parameter :: F00 = "('(shr_sys_system) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: an architecture independent system call +!------------------------------------------------------------------------------- + rcode = 0 +#ifdef HAVE_EXECUTE + call execute_command_line(str,exitstat=rcode) ! Intrinsic as of F2008 +#else +#if (defined AIX) + + call system(str,rcode) + +#elif (defined CPRGNU || defined LINUX) + + rcode = system(str) + +#else + + write(s_logunit,F00) 'ERROR: no implementation of system call for this architecture'//trim(str) + call shr_sys_abort(subName//'no implementation of system call for this architecture') +#endif +#endif + +END SUBROUTINE shr_sys_system + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_chdir(path, rcode) + + IMPLICIT none + + !----- arguments ----- + character(*) ,intent(in) :: path ! chdir to this dir + integer(SHR_KIND_IN),intent(out) :: rcode ! return code + + !----- local ----- + integer(SHR_KIND_IN) :: lenpath ! length of path +#if (defined AIX || (defined LINUX && !defined CPRGNU && !defined CPRNAG) || defined CPRINTEL) + integer(SHR_KIND_IN),external :: chdir ! AIX system call +#endif + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_chdir) ' + character(*),parameter :: F00 = "('(shr_sys_chdir) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: an architecture independent system call +!------------------------------------------------------------------------------- + rcode = 0 + lenpath=len_trim(path) + +#if (defined AIX) + + rcode = chdir(%ref(path(1:lenpath)//'\0')) + +#elif (defined Darwin || (defined LINUX && !defined CPRNAG)) + + rcode=chdir(path(1:lenpath)) + +#elif (defined CPRNAG) + + call chdir(path(1:lenpath), errno=rcode) + +#else + + write(s_logunit,F00) 'ERROR: no implementation of chdir for this architecture' + call shr_sys_abort(subname//'no implementation of chdir for this machine') + +#endif + +END SUBROUTINE shr_sys_chdir + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_getenv(name, val, rcode) + + IMPLICIT none + + !----- arguments ----- + character(*) ,intent(in) :: name ! env var name + character(*) ,intent(out) :: val ! env var value + integer(SHR_KIND_IN),intent(out) :: rcode ! return code + + !----- local ----- +#ifndef HAVE_GET_ENVIRONMENT + integer(SHR_KIND_IN) :: lenname ! length of env var name + integer(SHR_KIND_IN) :: lenval ! length of env var value + character(SHR_KIND_CL) :: tmpval ! temporary env var value +#endif + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_getenv) ' + character(*),parameter :: F00 = "('(shr_sys_getenv) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: an architecture independent system call +!------------------------------------------------------------------------------- + +!$OMP master + +#ifdef HAVE_GET_ENVIRONMENT + call get_environment_variable(name=name,value=val,status=rcode) ! Intrinsic in F2003 +#else + lenname=len_trim(name) +#if (defined AIX || defined LINUX) + + call getenv(trim(name),tmpval) + val=trim(tmpval) + rcode = 0 + if (len_trim(val) == 0 ) rcode = 1 + if (len_trim(val) > SHR_KIND_CL) rcode = 2 + +#else + + write(s_logunit,F00) 'ERROR: no implementation of getenv for this architecture' + call shr_sys_abort(subname//'no implementation of getenv for this machine') + +#endif +#endif +!$OMP end master + +END SUBROUTINE shr_sys_getenv + +!=============================================================================== +!=============================================================================== + +integer(SHR_KIND_I8) FUNCTION shr_sys_irtc( rate ) + + IMPLICIT none + + !----- arguments ----- + integer(SHR_KIND_I8), optional :: rate + + !----- local ----- + integer(SHR_KIND_IN) :: count + integer(SHR_KIND_IN) :: count_rate + integer(SHR_KIND_IN) :: count_max + + integer(SHR_KIND_IN),save :: last_count = -1 + integer(SHR_KIND_I8),save :: count_offset = 0 +!$OMP THREADPRIVATE (last_count, count_offset) + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_irtc) ' + character(*),parameter :: F00 = "('(shr_sys_irtc) ',4a)" + +!------------------------------------------------------------------------------- +! emulates Cray/SGI irtc function (returns clock tick since last reboot) +! +! This function is not intended to measure elapsed time between +! multi-threaded regions with different numbers of threads. However, +! use of the threadprivate declaration does guarantee accurate +! measurement per thread within a single multi-threaded region as +! long as the number of threads is not changed dynamically during +! execution within the multi-threaded region. +! +!------------------------------------------------------------------------------- + + call system_clock(count=count,count_rate=count_rate, count_max=count_max) + if ( present(rate) ) rate = count_rate + shr_sys_irtc = count + + !--- adjust for clock wrap-around --- + if ( last_count /= -1 ) then + if ( count < last_count ) count_offset = count_offset + count_max + end if + shr_sys_irtc = shr_sys_irtc + count_offset + last_count = count + +END FUNCTION shr_sys_irtc + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_sleep(sec) + + IMPLICIT none + + !----- arguments ----- + real (SHR_KIND_R8),intent(in) :: sec ! number of seconds to sleep + + !----- local ----- + integer(SHR_KIND_IN) :: isec ! integer number of seconds +#ifndef HAVE_SLEEP + integer(SHR_KIND_IN) :: rcode ! return code + character(90) :: str ! system call string +#endif + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_sleep) ' + character(*),parameter :: F00 = "('(shr_sys_sleep) ',4a)" + character(*),parameter :: F10 = "('sleep ',i8 )" + +!------------------------------------------------------------------------------- +! PURPOSE: Sleep for approximately sec seconds +!------------------------------------------------------------------------------- + + isec = nint(sec) + + if (isec < 0) then + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: seconds must be > 0, sec=',sec + else if (isec == 0) then + ! Don't consider this an error and don't call system sleep + else +#ifdef HAVE_SLEEP + call sleep(isec) +#else + write(str,FMT=F10) isec + call shr_sys_system( str, rcode ) +#endif + endif + +END SUBROUTINE shr_sys_sleep + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_flush(unit) + + IMPLICIT none + + !----- arguments ----- + integer(SHR_KIND_IN) :: unit ! flush output buffer for this unit + + !----- local ----- + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_flush) ' + character(*),parameter :: F00 = "('(shr_sys_flush) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: an architecture independent system call +! +! This is probably no longer needed; the "flush" statement is supported by +! all compilers that CESM supports for years now. +! +!------------------------------------------------------------------------------- +!$OMP SINGLE + flush(unit) +!$OMP END SINGLE +! +! The following code was originally present, but there's an obvious issue. +! Since shr_sys_flush is usually used to flush output to a log, when it +! returns an error, does it do any good to print that error to the log? +! +! if (ierr > 0) then +! write(s_logunit,*) subname,' Flush reports error: ',ierr +! endif +! + +END SUBROUTINE shr_sys_flush + +!=============================================================================== +!=============================================================================== + +END MODULE shr_sys_mod From fda65854228fea103fa2c83afa71efe1a9a490de Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Thu, 13 Jun 2024 16:21:28 -0600 Subject: [PATCH 04/47] update mediator med.F90 with sofar --- mediator/med.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/mediator/med.F90 b/mediator/med.F90 index 4fdbb06a6..53fe352e5 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -51,6 +51,7 @@ module MED use esmFldsExchange_ufs_mod , only : esmFldsExchange_ufs use esmFldsExchange_cesm_mod , only : esmFldsExchange_cesm use esmFldsExchange_hafs_mod , only : esmFldsExchange_hafs + use esmFldsExchange_sofar_mod, only : esmFldsExchange_sofar use med_phases_profile_mod , only : med_phases_profile_finalize implicit none @@ -838,6 +839,9 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) else if (coupling_mode(1:4) == 'hafs') then call esmFldsExchange_hafs(gcomp, phase='advertise', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + else if (coupling_mode(1:5) == 'sofar') then + call esmFldsExchange_sofar(gcomp, phase='advertise', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else call ESMF_LogWrite(trim(coupling_mode)//' is not a valid coupling_mode', ESMF_LOGMSG_INFO) call ESMF_Finalize(endflag=ESMF_END_ABORT) @@ -1847,6 +1851,9 @@ subroutine DataInitialize(gcomp, rc) else if (coupling_mode(1:4) == 'hafs') then call esmFldsExchange_hafs(gcomp, phase='initialize', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + else if (coupling_mode(1:5) == 'sofar') then + call esmFldsExchange_sofar(gcomp, phase='initialize', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (maintask) then From 852248f04e32b91193cf828f472bab78ff8c0b33 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Thu, 13 Jun 2024 16:23:17 -0600 Subject: [PATCH 05/47] add sofar to mediator Makefile --- mediator/Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/mediator/Makefile b/mediator/Makefile index 990fe58eb..7ee064c7a 100644 --- a/mediator/Makefile +++ b/mediator/Makefile @@ -36,11 +36,12 @@ esmFlds.o : med_kind_mod.o esmFldsExchange_cesm_mod.o : med_kind_mod.o med_methods_mod.o esmFlds.o med_internalstate_mod.o med_utils_mod.o esmFldsExchange_ufs_mod.o : med_kind_mod.o med_methods_mod.o esmFlds.o med_internalstate_mod.o med_utils_mod.o esmFldsExchange_hafs_mod.o : med_kind_mod.o med_methods_mod.o esmFlds.o med_internalstate_mod.o med_utils_mod.o +esmFldsExchange_sofar_mod.o : med_kind_mod.o med_methods_mod.o esmFlds.o med_internalstate_mod.o med_utils_mod.o med.o : med_kind_mod.o med_phases_profile_mod.o med_utils_mod.o med_phases_prep_rof_mod.o med_phases_aofluxes_mod.o \ med_phases_prep_ice_mod.o med_fraction_mod.o med_map_mod.o med_constants_mod.o med_phases_prep_wav_mod.o \ med_phases_prep_lnd_mod.o med_phases_history_mod.o med_phases_ocnalb_mod.o med_phases_restart_mod.o \ med_time_mod.o med_internalstate_mod.o med_phases_prep_atm_mod.o esmFldsExchange_cesm_mod.o esmFldsExchange_ufs_mod.o \ - esmFldsExchange_hafs_mod.o med_phases_prep_glc_mod.o esmFlds.o med_io_mod.o med_methods_mod.o med_phases_prep_ocn_mod.o \ + esmFldsExchange_hafs_mod.o esmFldsExchange_sofar_mod.o med_phases_prep_glc_mod.o esmFlds.o med_io_mod.o med_methods_mod.o med_phases_prep_ocn_mod.o \ med_phases_post_atm_mod.o med_phases_post_ice_mod.o med_phases_post_lnd_mod.o med_phases_post_glc_mod.o med_phases_post_rof_mod.o \ med_phases_post_wav_mod.o med_fraction_mod.o : med_kind_mod.o med_utils_mod.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o med_methods_mod.o esmFlds.o From fda04908d5c734f746b92dee76e4b360cb0d372b Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Thu, 13 Jun 2024 16:24:26 -0600 Subject: [PATCH 06/47] add sofar app file --- mediator/esmFldsExchange_sofar_mod.F90 | 773 +++++++++++++++++++++++++ 1 file changed, 773 insertions(+) create mode 100644 mediator/esmFldsExchange_sofar_mod.F90 diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 new file mode 100644 index 000000000..dc24f62a2 --- /dev/null +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -0,0 +1,773 @@ +module esmFldsExchange_sofar_mod + + use ESMF + use NUOPC + use med_utils_mod , only : chkerr => med_utils_chkerr + use med_kind_mod , only : CX=>SHR_KIND_CX + use med_kind_mod , only : CS=>SHR_KIND_CS + use med_kind_mod , only : CL=>SHR_KIND_CL + use med_kind_mod , only : R8=>SHR_KIND_R8 + use med_internalstate_mod , only : compmed + use med_internalstate_mod , only : compatm + use med_internalstate_mod , only : compocn + use med_internalstate_mod , only : compwav + use med_internalstate_mod , only : ncomps + use med_internalstate_mod , only : coupling_mode + use esmFlds , only : addfld_ocnalb => med_fldList_addfld_ocnalb + + !--------------------------------------------------------------------- + ! This is a mediator specific routine that determines ALL possible + ! fields exchanged between components and their associated routing, + ! mapping and merging + !--------------------------------------------------------------------- + + implicit none + public + + public :: esmFldsExchange_sofar + + character(*), parameter :: u_FILE_u = & + __FILE__ + + type gcomp_attr + character(len=CX) :: atm2ocn_fmap = 'unset' + character(len=CX) :: atm2ocn_smap = 'unset' + character(len=CX) :: atm2ocn_vmap = 'unset' + character(len=CX) :: atm2wav_smap = 'unset' + character(len=CX) :: ocn2atm_fmap = 'unset' + character(len=CX) :: ocn2atm_smap = 'unset' + character(len=CX) :: ocn2wav_smap = 'unset' + character(len=CX) :: wav2ocn_smap = 'unset' + character(len=CX) :: wav2atm_smap = 'unset' + character(len=CS) :: mapnorm = 'one' + logical :: atm_present = .false. + logical :: ocn_present = .false. + logical :: wav_present = .false. + end type + +!=============================================================================== +contains +!=============================================================================== + + subroutine esmFldsExchange_sofar(gcomp, phase, rc) + + ! input/output parameters: + type(ESMF_GridComp) :: gcomp + character(len=*) , intent(in) :: phase + integer , intent(inout) :: rc + + ! local variables: + character(len=*) , parameter :: subname='(esmFldsExchange_sofar)' + !-------------------------------------- + + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + rc = ESMF_SUCCESS + + if (phase == 'advertise') then + call esmFldsExchange_sofar_advt(gcomp, phase, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (phase == 'fieldcheck') then + call esmFldsExchange_sofar_fchk(gcomp, phase, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (phase == 'initialize') then + call esmFldsExchange_sofar_init(gcomp, phase, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogSetError(ESMF_FAILURE, & + msg=trim(subname)//": Phase is set to "//trim(phase), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return ! bail out + endif + + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + + end subroutine esmFldsExchange_sofar + + !----------------------------------------------------------------------------- + + subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) + + use esmFlds, only : addfld_to => med_fldList_addfld_to + use esmFlds, only : addfld_from => med_fldList_addfld_from + + ! input/output parameters: + type(ESMF_GridComp) :: gcomp + character(len=*) , intent(in) :: phase + integer , intent(inout) :: rc + + ! local variables: + integer :: n + logical :: isPresent + character(len=CL) :: cvalue + character(len=CS) :: fldname + character(len=CS) :: fldname1, fldname2 + type(gcomp_attr) :: sofar_attr + character(len=CS), allocatable :: S_flds(:) + character(len=CS), allocatable :: F_flds(:,:) + character(len=*) , parameter :: subname='(esmFldsExchange_sofar_advt)' + !-------------------------------------- + + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + rc = ESMF_SUCCESS + + !===================================================================== + ! scalar information + !===================================================================== + + call NUOPC_CompAttributeGet(gcomp, name='ScalarFieldName', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", & + value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do n = 1,ncomps + call addfld_from(n, trim(cvalue)) + call addfld_to(n, trim(cvalue)) + end do + end if + + !===================================================================== + ! attribute settings + !===================================================================== + call esmFldsExchange_sofar_attr(gcomp, sofar_attr, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !===================================================================== + ! Mediator fields + !===================================================================== + + !---------------------------------------------------------- + ! to med: masks from components + !---------------------------------------------------------- + call addfld_from(compocn, 'So_omask') + + !---------------------------------------------------------- + ! to med: frac from components + !---------------------------------------------------------- + call addfld_to(compatm, 'So_ofrac') + + !---------------------------------------------------------- + ! from med: ocean albedos (not sent to the ATM in UFS). + !---------------------------------------------------------- + if (trim(coupling_mode) == 'sofar.mom6') then + if (phase == 'advertise') then + call addfld_ocnalb('So_avsdr') + call addfld_ocnalb('So_avsdf') + call addfld_ocnalb('So_anidr') + call addfld_ocnalb('So_anidf') + end if + end if + + !===================================================================== + ! FIELDS TO ATMOSPHERE + !===================================================================== + + ! --------------------------------------------------------------------- + ! to atm: surface temperatures from ocn + ! --------------------------------------------------------------------- + if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then + if (trim(coupling_mode) == 'sofar') then + allocate(S_flds(1)) + S_flds = (/'So_t'/) ! sea_surface_temperature + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compocn, trim(fldname)) + call addfld_to(compatm, trim(fldname)) + end do + deallocate(S_flds) + else + allocate(S_flds(3)) + S_flds = (/'So_t', & ! sea_surface_temperature + 'So_u', & ! surface zonal current + 'So_v'/) ! surface meridional current + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compocn, trim(fldname)) + call addfld_to(compatm, trim(fldname)) + end do + deallocate(S_flds) + end if + end if + + ! --------------------------------------------------------------------- + ! to atm: surface roughness length + ! --------------------------------------------------------------------- + if (sofar_attr%atm_present .and. sofar_attr%wav_present) then + allocate(S_flds(1)) + S_flds = (/'Sw_z0'/) ! wave_z0_roughness_length + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compwav, trim(fldname)) + call addfld_to(compatm, trim(fldname)) + end do + deallocate(S_flds) + end if + + !===================================================================== + ! FIELDS TO OCEAN (compocn) + !===================================================================== + + ! --------------------------------------------------------------------- + ! to ocn: state fields + ! --------------------------------------------------------------------- + if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then + if (trim(coupling_mode) == 'sofar') then + allocate(S_flds(6)) + S_flds = (/'Sa_u10m', & ! inst_zonal_wind_height10m + 'Sa_v10m', & ! inst_merid_wind_height10m + 'Sa_t2m ', & ! inst_temp_height2m + 'Sa_q2m ', & ! inst_spec_humid_height2m + 'Sa_pslv', & ! inst_pres_height_surface + 'Sa_tskn' /) ! inst_temp_height_surface + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compatm, trim(fldname)) + call addfld_to(compocn, trim(fldname)) + end do + deallocate(S_flds) + else + allocate(S_flds(1)) + S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compatm, trim(fldname)) + call addfld_to(compocn, trim(fldname)) + end do + deallocate(S_flds) + end if + end if + + ! --------------------------------------------------------------------- + ! to ocn: flux fields + ! --------------------------------------------------------------------- + if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then + if (trim(coupling_mode) == 'sofar') then + allocate(F_flds(7,2)) + F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm + F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm + F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate + F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx + F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx + F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx + F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx + do n = 1,size(F_flds,1) + fldname1 = trim(F_flds(n,1)) + fldname2 = trim(F_flds(n,2)) + call addfld_from(compatm, trim(fldname1)) + call addfld_to(compocn, trim(fldname2)) + end do + deallocate(F_flds) + else + allocate(F_flds(10,2)) + F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm + F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm + F_flds(3 ,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate + F_flds(4 ,:) = (/'Faxa_lwnet ','Foxx_lwnet '/) ! inst_net_lw_flx + F_flds(5 ,:) = (/'Faxa_sen ','Foxx_sen '/) ! inst_sensi_heat_flx + F_flds(6 ,:) = (/'Faxa_evap ','Foxx_evap '/) ! inst_evap_rate + F_flds(7 ,:) = (/'Faxa_swndr ','Foxx_swnet_idr'/) ! inst_down_sw_ir_dir_flx + F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx + F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx + F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx + do n = 1,size(F_flds,1) + fldname1 = trim(F_flds(n,1)) + fldname2 = trim(F_flds(n,2)) + call addfld_from(compatm, trim(fldname1)) + call addfld_to(compocn, trim(fldname2)) + end do + deallocate(F_flds) + end if + end if + + !===================================================================== + ! FIELDS TO WAVE (compwav) + !===================================================================== + + ! --------------------------------------------------------------------- + ! to wav: 10-m wind components + ! --------------------------------------------------------------------- + if (sofar_attr%atm_present .and. sofar_attr%wav_present) then + allocate(S_flds(2)) + S_flds = (/'Sa_u10m', 'Sa_v10m'/) + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compatm, trim(fldname)) + call addfld_to(compwav, trim(fldname)) + end do + deallocate(S_flds) + end if + + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + + end subroutine esmFldsExchange_sofar_advt + + !----------------------------------------------------------------------------- + + subroutine esmFldsExchange_sofar_fchk(gcomp, phase, rc) + + use med_methods_mod , only : fldchk => med_methods_FB_FldChk + use med_internalstate_mod , only : InternalState + + ! input/output parameters: + type(ESMF_GridComp) :: gcomp + character(len=*) , intent(in) :: phase + integer , intent(inout) :: rc + + ! local variables: + type(InternalState) :: is_local + character(len=*) , parameter :: subname='(esmFldsExchange_sofar_fchk)' + !-------------------------------------- + + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + rc = ESMF_SUCCESS + + !--------------------------------------- + ! Get the internal state + !--------------------------------------- + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (fldchk(is_local%wrap%FBImp(compocn,compocn),'So_omask',rc=rc)) then + call ESMF_LogWrite(trim(subname)//": Field connected "//"So_omask", & + ESMF_LOGMSG_INFO) + else + call ESMF_LogSetError(ESMF_FAILURE, & + msg=trim(subname)//": Field is not connected "//"So_omask", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return ! bail out + endif + + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + + end subroutine esmFldsExchange_sofar_fchk + + !----------------------------------------------------------------------------- + + subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) + + use med_methods_mod , only : fldchk => med_methods_FB_FldChk + use med_internalstate_mod , only : InternalState + use med_internalstate_mod , only : mapbilnr, mapconsf, mapconsd, mappatch + use med_internalstate_mod , only : mapfcopy, mapnstod, mapnstod_consd + use med_internalstate_mod , only : mapfillv_bilnr + use med_internalstate_mod , only : mapnstod_consf + use esmFlds , only : addmap_from => med_fldList_addmap_from + use esmFlds , only : addmrg_to => med_fldList_addmrg_to + + ! input/output parameters: + type(ESMF_GridComp) :: gcomp + character(len=*) , intent(in) :: phase + integer , intent(inout) :: rc + + ! local variables: + type(InternalState) :: is_local + integer :: n + character(len=CS) :: fldname + character(len=CS) :: fldname1, fldname2 + type(gcomp_attr) :: sofar_attr + character(len=CS), allocatable :: S_flds(:) + character(len=CS), allocatable :: F_flds(:,:) + character(len=*) , parameter :: subname='(esmFldsExchange_sofar_init)' + !-------------------------------------- + + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + rc = ESMF_SUCCESS + + !--------------------------------------- + ! Get the internal state + !--------------------------------------- + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------------- + ! Merging arguments: + ! mrg_fromN = source component index that for the field to be merged + ! mrg_fldN = souce field name to be merged + ! mrg_typeN = merge type ('copy', 'copy_with_weights', 'sum', + ! 'sum_with_weights', 'merge') + ! NOTE: + ! mrg_from(compmed) can either be for mediator computed fields for atm/ocn + ! fluxes or for ocn albedos + ! + ! NOTE: + ! FBMed_aoflux_o only refer to output fields to the atm/ocn that computed in + ! the atm/ocn flux calculations. Input fields required from either the atm + ! or the ocn for these computation will use the logical 'use_med_aoflux' + ! below. This is used to determine mappings between the atm and ocn needed + ! for these computations. + !-------------------------------------- + + !===================================================================== + ! attribute settings + !===================================================================== + call esmFldsExchange_sofar_attr(gcomp, sofar_attr, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !===================================================================== + ! FIELDS TO ATMOSPHERE + !===================================================================== + + ! --------------------------------------------------------------------- + ! to atm: sea surface temperature + ! --------------------------------------------------------------------- + if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then + if (trim(coupling_mode) == 'sofar') then + allocate(S_flds(1)) + S_flds = (/'So_t'/) ! sea_surface_temperature + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn),trim(fldname),rc=rc) & + ) then + call addmap_from(compocn, trim(fldname), compatm, & + mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%ocn2atm_smap) + call addmrg_to(compatm, trim(fldname), & + mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + end if + end do + deallocate(S_flds) + else + allocate(S_flds(3)) + S_flds = (/'So_t', & ! sea_surface_temperature + 'So_u', & ! surface zonal current + 'So_v'/) ! surface meridional current + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn),trim(fldname),rc=rc) & + ) then + call addmap_from(compocn, trim(fldname), compatm, & + mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%ocn2atm_smap) + call addmrg_to(compatm, trim(fldname), & + mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + end if + end do + deallocate(S_flds) + end if + end if + + ! --------------------------------------------------------------------- + ! to atm: surface roughness length + ! --------------------------------------------------------------------- + if (sofar_attr%atm_present .and. sofar_attr%wav_present) then + allocate(S_flds(1)) + S_flds = (/'Sw_z0'/) ! wave_z0_roughness_length + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav,compwav),trim(fldname),rc=rc) & + ) then + call addmap_from(compwav, trim(fldname), compatm, & + mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%wav2atm_smap) + call addmrg_to(compatm, trim(fldname), & + mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') + end if + end do + deallocate(S_flds) + end if + + !===================================================================== + ! FIELDS TO OCEAN (compocn) + !===================================================================== + + ! --------------------------------------------------------------------- + ! to ocn: state fields + ! --------------------------------------------------------------------- + if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then + if (trim(coupling_mode) == 'sofar') then + allocate(S_flds(6)) + S_flds = (/'Sa_u10m', & ! inst_zonal_wind_height10m + 'Sa_v10m', & ! inst_merid_wind_height10m + 'Sa_t2m ', & ! inst_temp_height2m + 'Sa_q2m ', & ! inst_spec_humid_height2m + 'Sa_pslv', & ! inst_pres_height_surface + 'Sa_tskn' /) ! inst_temp_height_surface + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname),rc=rc) & + ) then + call addmap_from(compatm, trim(fldname), compocn, & + mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%atm2ocn_smap) + call addmrg_to(compocn, trim(fldname), & + mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end if + end do + deallocate(S_flds) + else + allocate(S_flds(1)) + S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname),rc=rc) & + ) then + call addmap_from(compatm, trim(fldname), compocn, & + mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%atm2ocn_smap) + call addmrg_to(compocn, trim(fldname), & + mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end if + end do + deallocate(S_flds) + end if + end if + + ! --------------------------------------------------------------------- + ! to ocn: flux fields + ! --------------------------------------------------------------------- + if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then + if (trim(coupling_mode) == 'sofar') then + allocate(F_flds(7,2)) + F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm + F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm + F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate + F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx + F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx + F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx + F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx + do n = 1,size(F_flds,1) + fldname1 = trim(F_flds(n,1)) + fldname2 = trim(F_flds(n,2)) + if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname2),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname1),rc=rc) & + ) then + call addmap_from(compatm, trim(fldname1), compocn, & + mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%atm2ocn_smap) + call addmrg_to(compocn, trim(fldname2), & + mrg_from=compatm, mrg_fld=trim(fldname1), mrg_type='copy') + end if + end do + deallocate(F_flds) + else + allocate(F_flds(10,2)) + F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm + F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm + F_flds(3 ,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate + F_flds(4 ,:) = (/'Faxa_lwnet ','Foxx_lwnet '/) ! inst_net_lw_flx + F_flds(5 ,:) = (/'Faxa_sen ','Foxx_sen '/) ! inst_sensi_heat_flx + F_flds(6 ,:) = (/'Faxa_evap ','Foxx_evap '/) ! inst_evap_rate + F_flds(7 ,:) = (/'Faxa_swndr ','Foxx_swnet_idr'/) ! inst_down_sw_ir_dir_flx + F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx + F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx + F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx + do n = 1,size(F_flds,1) + fldname1 = trim(F_flds(n,1)) + fldname2 = trim(F_flds(n,2)) + if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname2),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname1),rc=rc) & + ) then + call addmap_from(compatm, trim(fldname1), compocn, & + mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%atm2ocn_smap) + call addmrg_to(compocn, trim(fldname2), & + mrg_from=compatm, mrg_fld=trim(fldname1), mrg_type='copy') + end if + end do + deallocate(F_flds) + end if + end if + + !===================================================================== + ! FIELDS TO WAVE (compwav) + !===================================================================== + + ! --------------------------------------------------------------------- + ! to wav: 10-m wind components + ! --------------------------------------------------------------------- + if (sofar_attr%atm_present .and. sofar_attr%wav_present) then + allocate(S_flds(2)) + S_flds = (/'Sa_u10m', 'Sa_v10m'/) + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + if (fldchk(is_local%wrap%FBexp(compwav),trim(fldname),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), trim(fldname),rc=rc) & + ) then + call addmap_from(compatm, trim(fldname), compwav, & + mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%atm2wav_smap) + call addmrg_to(compwav, trim(fldname), & + mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end if + end do + deallocate(S_flds) + end if + + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + + end subroutine esmFldsExchange_sofar_init + + !----------------------------------------------------------------------------- + + subroutine esmFldsExchange_sofar_attr(gcomp, sofar_attr, rc) + + ! input/output parameters: + type(ESMF_GridComp) :: gcomp + type(gcomp_attr) , intent(inout) :: sofar_attr + integer , intent(inout) :: rc + + ! local variables: + character(32) :: cname + integer :: verbosity, diagnostic + character(len=CL) :: cvalue + logical :: isPresent, isSet + character(len=*) , parameter :: subname='(esmFldsExchange_sofar_attr)' + !-------------------------------------- + + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + rc = ESMF_SUCCESS + + ! Query component for name, verbosity, and diagnostic values + call NUOPC_CompGet(gcomp, name=cname, verbosity=verbosity, & + diagnostic=diagnostic, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !---------------------------------------------------------- + ! Component active or not? + !---------------------------------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name='ATM_model', & + value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(cvalue) /= 'satm') sofar_attr%atm_present = .true. + end if + + call NUOPC_CompAttributeGet(gcomp, name='OCN_model', & + value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(cvalue) /= 'socn') sofar_attr%ocn_present = .true. + end if + + call NUOPC_CompAttributeGet(gcomp, name='WAV_model', & + value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(cvalue) /= 'swav') sofar_attr%wav_present = .true. + end if + + !---------------------------------------------------------- + ! Normalization type + !---------------------------------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name='normalization', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='normalization', & + value=sofar_attr%mapnorm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + !---------------------------------------------------------- + ! Initialize mapping file names + !---------------------------------------------------------- + + ! to atm + call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_smapname', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_smapname', & + value=sofar_attr%ocn2atm_smap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_fmapname', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_fmapname', & + value=sofar_attr%ocn2atm_fmap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + ! to ocn + call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_fmapname', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_fmapname', & + value=sofar_attr%atm2ocn_fmap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_smapname', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_smapname', & + value=sofar_attr%atm2ocn_smap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_vmapname', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_vmapname', & + value=sofar_attr%atm2ocn_vmap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + ! to wav + call NUOPC_CompAttributeGet(gcomp, name='atm2wav_smapname', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='atm2wav_smapname', & + value=sofar_attr%atm2wav_smap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + call NUOPC_CompAttributeGet(gcomp, name='ocn2wav_smapname', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='ocn2wav_smapname', & + value=sofar_attr%ocn2wav_smap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + ! from wav + call NUOPC_CompAttributeGet(gcomp, name='wav2atm_smapname', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='wav2atm_smapname', & + value=sofar_attr%wav2atm_smap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + call NUOPC_CompAttributeGet(gcomp, name='wav2ocn_smapname', & + isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='wav2ocn_smapname', & + value=sofar_attr%wav2ocn_smap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + ! Log Attribute Settings + if (btest(verbosity,16)) then + write(cvalue,"(I0)") verbosity + call ESMF_LogWrite(trim(subname)//': Verbosity = '// & + trim(cvalue), ESMF_LOGMSG_INFO) + write(cvalue,"(I0)") diagnostic + call ESMF_LogWrite(trim(subname)//': Diagnostic = '// & + trim(cvalue), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//': normalization = '// & + trim(sofar_attr%mapnorm), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//': ocn2atm_smapname = '// & + trim(sofar_attr%ocn2atm_smap), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//': ocn2atm_fmapname = '// & + trim(sofar_attr%ocn2atm_fmap), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//': atm2ocn_fmapname = '// & + trim(sofar_attr%atm2ocn_fmap), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//': atm2ocn_smapname = '// & + trim(sofar_attr%atm2ocn_smap), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//': atm2ocn_vmapname = '// & + trim(sofar_attr%atm2ocn_vmap), ESMF_LOGMSG_INFO) + endif + + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + + end subroutine esmFldsExchange_sofar_attr + +end module esmFldsExchange_sofar_mod From 77c2d222ca0ab6567f74010532fa352f8ae762f5 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Fri, 14 Jun 2024 11:46:34 -0600 Subject: [PATCH 07/47] Create README.md provide information about file sources --- shared/README.md | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 shared/README.md diff --git a/shared/README.md b/shared/README.md new file mode 100644 index 000000000..f083d36ff --- /dev/null +++ b/shared/README.md @@ -0,0 +1,14 @@ +### Original source of files: +Accessed on 6/13/24: +``` +mkdir -p ${CMEPS_DIR}/shared \ + && wget https://raw.githubusercontent.com/ufs-community/ufs-weather-model/develop/CDEPS-interface/ufs/cdeps_share/shr_infnan_mod.F90 \ + && wget https://raw.githubusercontent.com/ufs-community/ufs-weather-model/develop/CDEPS-interface/ufs/cdeps_share/dtypes.h \ + && wget https://raw.githubusercontent.com/ESCOMP/CDEPS/main/share/shr_kind_mod.F90 \ + && wget https://raw.githubusercontent.com/ESCOMP/CDEPS/main/share/shr_orb_mod.F90 \ + && wget https://raw.githubusercontent.com/ESCOMP/CDEPS/main/share/shr_sys_mod.F90 \ + && wget https://raw.githubusercontent.com/ESCOMP/CDEPS/main/share/shr_log_mod.F90 \ + && wget https://raw.githubusercontent.com/ESCOMP/CDEPS/main/share/shr_strconvert_mod.F90 \ + && wget https://raw.githubusercontent.com/ESCOMP/CDEPS/main/share/shr_abort_mod.F90 \ + && wget https://raw.githubusercontent.com/ESCOMP/CDEPS/main/share/shr_const_mod.F90 +``` From 3b160fa7057047abf063452d79c16fde0a775b3d Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Fri, 14 Jun 2024 11:51:50 -0600 Subject: [PATCH 08/47] Update README.md adding some instructions for building --- README.md | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index a82ae3618..da8fe9947 100644 --- a/README.md +++ b/README.md @@ -11,4 +11,12 @@ coupled system application. For documentation see -https://escomp.github.io/CMEPS/ +https://escomp.github.io/CMEPS/ + +In order to build the package, the NCAR [ParallelIO package](https://github.com/NCAR/ParallelIO) must be installed and an environment variable PIO=${PIO_DIRECTORY} set. [PnetCDF](https://github.com/Parallel-NetCDF/PnetCDF) is optional. + +To build stand-alone libraries, run: +``` +cmake . +make +``` From b6af5329981c563dea0f50010af9f2ad03bc6c33 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Fri, 14 Jun 2024 11:53:27 -0600 Subject: [PATCH 09/47] Update README.md --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index da8fe9947..ae1eef903 100644 --- a/README.md +++ b/README.md @@ -13,6 +13,8 @@ For documentation see https://escomp.github.io/CMEPS/ +## Building + In order to build the package, the NCAR [ParallelIO package](https://github.com/NCAR/ParallelIO) must be installed and an environment variable PIO=${PIO_DIRECTORY} set. [PnetCDF](https://github.com/Parallel-NetCDF/PnetCDF) is optional. To build stand-alone libraries, run: From ef0798a59d901365944d9560f2000aa79b3ddf86 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Fri, 14 Jun 2024 20:07:28 -0600 Subject: [PATCH 10/47] Update CMakeLists.txt added for clarity --- CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 8e50ee2e9..45c9770df 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -39,6 +39,7 @@ if (NOT DEFINED MPILIB OR NOT ${MPILIB} STREQUAL "mpi-serial") find_package(MPI REQUIRED) endif() +message(BLD_STANDALONE="${BLD_STANDALONE}") if(BLD_STANDALONE) add_subdirectory(ufs) list(APPEND EXTRA_LIBS cmeps_share) From af8760156d3c133d5ab3b128e477cea4bd06ef72 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Fri, 14 Jun 2024 20:11:54 -0600 Subject: [PATCH 11/47] Update CMakeLists.txt adding sofar file --- mediator/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/mediator/CMakeLists.txt b/mediator/CMakeLists.txt index 9630b5e23..e0924172b 100644 --- a/mediator/CMakeLists.txt +++ b/mediator/CMakeLists.txt @@ -3,6 +3,7 @@ project(cmeps Fortran) set(SRCFILES esmFldsExchange_cesm_mod.F90 med_fraction_mod.F90 med_methods_mod.F90 med_phases_prep_ice_mod.F90 med_phases_restart_mod.F90 esmFldsExchange_hafs_mod.F90 + esmFldsExchange_sofar_mod.F90 med_internalstate_mod.F90 med_phases_aofluxes_mod.F90 med_phases_prep_lnd_mod.F90 med_time_mod.F90 esmFldsExchange_ufs_mod.F90 med_io_mod.F90 From 6da7ab28b6fb3685dc74709b36300f937490002f Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Fri, 14 Jun 2024 20:17:11 -0600 Subject: [PATCH 12/47] Update CMakeLists.txt new, but seems like a necessary change --- mediator/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/mediator/CMakeLists.txt b/mediator/CMakeLists.txt index e0924172b..34b1c82b0 100644 --- a/mediator/CMakeLists.txt +++ b/mediator/CMakeLists.txt @@ -29,6 +29,7 @@ endforeach() add_library(cmeps ${SRCFILES}) if(BLD_STANDALONE) + add_dependencies(cmeps shared) add_dependencies(cmeps cmeps_share) endif() From e662b47119f81c24e7eeb648b8b5f2f0afc2e078 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Fri, 14 Jun 2024 22:20:41 -0600 Subject: [PATCH 13/47] Update CMakeLists.txt add include directories for shared library --- mediator/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/mediator/CMakeLists.txt b/mediator/CMakeLists.txt index 34b1c82b0..942b0fc06 100644 --- a/mediator/CMakeLists.txt +++ b/mediator/CMakeLists.txt @@ -35,6 +35,7 @@ endif() target_include_directories (cmeps PUBLIC ${ESMF_F90COMPILEPATHS}) target_include_directories (cmeps PUBLIC "${CMAKE_BINARY_DIR}/ufs") +target_include_directories (cmeps PUBLIC "${CMAKE_BINARY_DIR}/shared") target_include_directories (cmeps PUBLIC ${PIO_Fortran_INCLUDE_DIR}) install(TARGETS cmeps From 6d7a65575d9084215c0b2b479bdb1c0aebd8c425 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Tue, 18 Jun 2024 02:34:39 -0600 Subject: [PATCH 14/47] Create cmeps.mk create template for makefile fragment --- cmeps.mk | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 cmeps.mk diff --git a/cmeps.mk b/cmeps.mk new file mode 100644 index 000000000..dd61419a0 --- /dev/null +++ b/cmeps.mk @@ -0,0 +1,15 @@ +#----------------------------------------------- +# NUOPC/ESMF self-describing build dependency +# makefile fragment for CMEPS +#----------------------------------------------- + +# component module name +MED_ESMF_DEP_FRONT := MED +# component module path +MED_ESMF_DEP_INCPATH := +# component module objects +MED_ESMF_DEP_CMPL_OBJS := +# component object/archive list +MED_ESMF_DEP_LINK_OBJS := +MED_ESMF_DEP_SHRD_PATH := +MED_ESMF_DEP_SHRD_LIBS := From 6bd8279c26b9322b21d2c5be296c337ed38f5400 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Tue, 18 Jun 2024 02:48:38 -0600 Subject: [PATCH 15/47] Update cmeps.mk simplifying --- cmeps.mk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cmeps.mk b/cmeps.mk index dd61419a0..e1949b536 100644 --- a/cmeps.mk +++ b/cmeps.mk @@ -4,7 +4,7 @@ #----------------------------------------------- # component module name -MED_ESMF_DEP_FRONT := MED +MED_ESMF_DEP_FRONT := # component module path MED_ESMF_DEP_INCPATH := # component module objects From d0dea71ae03b3a257bfab6288d0368e4c70f4ea3 Mon Sep 17 00:00:00 2001 From: Steve Penny Date: Tue, 18 Jun 2024 14:37:54 -0600 Subject: [PATCH 16/47] Update cmeps.mk These probably won't change --- cmeps.mk | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/cmeps.mk b/cmeps.mk index e1949b536..28c448632 100644 --- a/cmeps.mk +++ b/cmeps.mk @@ -4,12 +4,6 @@ #----------------------------------------------- # component module name -MED_ESMF_DEP_FRONT := -# component module path -MED_ESMF_DEP_INCPATH := -# component module objects -MED_ESMF_DEP_CMPL_OBJS := -# component object/archive list -MED_ESMF_DEP_LINK_OBJS := +MED_ESMF_DEP_FRONT := MED MED_ESMF_DEP_SHRD_PATH := -MED_ESMF_DEP_SHRD_LIBS := +MED_ESMF_DEP_SHRD_LIBS := pioc piof cmeps shared cmeps_share From 40db5a8dfd48768056ae22ec2664161b69fc7f18 Mon Sep 17 00:00:00 2001 From: StevePny Date: Mon, 1 Jul 2024 06:51:47 +0000 Subject: [PATCH 17/47] modifications to run sofar vars minus neutral --- mediator/esmFldsExchange_sofar_mod.F90 | 50 ++++++++++++++++++++------ 1 file changed, 40 insertions(+), 10 deletions(-) diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 index dc24f62a2..e434e7a43 100644 --- a/mediator/esmFldsExchange_sofar_mod.F90 +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -140,12 +140,17 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) !---------------------------------------------------------- ! to med: masks from components !---------------------------------------------------------- - call addfld_from(compocn, 'So_omask') + if (sofar_attr%ocn_present) then ! Sofar system: added + call addfld_from(compocn, 'So_omask') + endif ! Sofar system: added !---------------------------------------------------------- ! to med: frac from components !---------------------------------------------------------- - call addfld_to(compatm, 'So_ofrac') + if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then ! Sofar system: added + call addfld_to(compatm, 'So_ofrac') +! call addfld_from(compatm , 'Sa_ofrac') ! Sofar system: added + endif ! Sofar system: added !---------------------------------------------------------- ! from med: ocean albedos (not sent to the ATM in UFS). @@ -170,6 +175,7 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) if (trim(coupling_mode) == 'sofar') then allocate(S_flds(1)) S_flds = (/'So_t'/) ! sea_surface_temperature + ! Sofar system: add surface temperature, or add NSST computation to mediator do n = 1,size(S_flds) fldname = trim(S_flds(n)) call addfld_from(compocn, trim(fldname)) @@ -191,11 +197,16 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) end if ! --------------------------------------------------------------------- - ! to atm: surface roughness length + ! to atm: Charnock parameter and surface roughness length ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%wav_present) then allocate(S_flds(1)) - S_flds = (/'Sw_z0'/) ! wave_z0_roughness_length + !allocate(S_flds(2)) ! Sofar system !ISSUE: add option to change the export vars at runtime +! S_flds = (/'Sw_z0rlen'/) ! wave_z0_roughness_length + S_flds = (/'Sw_charno'/) ! Charnock parameter + !S_flds = (/'Sw_z0rlen', & ! wave_z0_roughness_length ! Sofar system + ! 'Sw_charno', & ! Charnock parameter ! Sofar system + ! /) ! Sofar system do n = 1,size(S_flds) fldname = trim(S_flds(n)) call addfld_from(compwav, trim(fldname)) @@ -288,8 +299,15 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to wav: 10-m wind components ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%wav_present) then - allocate(S_flds(2)) - S_flds = (/'Sa_u10m', 'Sa_v10m'/) +! allocate(S_flds(2)) +! S_flds = (/'Sa_u10m', 'Sa_v10m'/) + allocate(S_flds(4)) ! Sofar system !ISSUE: add option to change the export vars at runtime + S_flds = (/'Sa_u10m', ! zonal diagnosed 10m wind component + 'Sa_v10m', ! meridional diagnosed 10m wind component + 'Sa_rhoa', ! atmospheric surface density + 'Sa_astdiff' ! air minus sea surface temperature difference + /) ! Sofar system with diagnosed 10m winds +! S_flds = (/'Sa_u10n', 'Sa_v10n', 'Sa_rhoa', 'Sa_astdiff'/) ! Sofar system with neutral winds do n = 1,size(S_flds) fldname = trim(S_flds(n)) call addfld_from(compatm, trim(fldname)) @@ -450,11 +468,16 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) end if ! --------------------------------------------------------------------- - ! to atm: surface roughness length + ! to atm: Charnock parameter and surface roughness length ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%wav_present) then allocate(S_flds(1)) - S_flds = (/'Sw_z0'/) ! wave_z0_roughness_length + !allocate(S_flds(2)) ! Sofar system !ISSUE: add option to change the export vars at runtime +! S_flds = (/'Sw_z0rlen'/) ! wave_z0_roughness_length + S_flds = (/'Sw_charno'/) ! Charnock parameter + !S_flds = (/'Sw_z0rlen', & ! wave_z0_roughness_length ! Sofar system + ! 'Sw_charno', & ! Charnock parameter ! Sofar system + ! /) do n = 1,size(S_flds) fldname = trim(S_flds(n)) if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & @@ -577,8 +600,15 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) ! to wav: 10-m wind components ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%wav_present) then - allocate(S_flds(2)) - S_flds = (/'Sa_u10m', 'Sa_v10m'/) +! allocate(S_flds(2)) +! S_flds = (/'Sa_u10m', 'Sa_v10m'/) + allocate(S_flds(4)) ! Sofar system !ISSUE: add option to change the export vars at runtime + S_flds = (/'Sa_u10m', ! zonal diagnosed 10m wind component + 'Sa_v10m', ! meridional diagnosed 10m wind component + 'Sa_rhoa', ! atmospheric surface density + 'Sa_astdiff' ! air minus sea surface temperature difference + /) ! Sofar system with diagnosed 10m winds + !S_flds = (/'Sa_u10n', 'Sa_v10n', 'Sa_rhoa', 'Sa_astdiff'/) ! Sofar system with neutral winds do n = 1,size(S_flds) fldname = trim(S_flds(n)) if (fldchk(is_local%wrap%FBexp(compwav),trim(fldname),rc=rc) .and. & From 17a755c4eb48e122ace4f65afff992b6dbd3cb05 Mon Sep 17 00:00:00 2001 From: StevePny Date: Mon, 1 Jul 2024 07:03:10 +0000 Subject: [PATCH 18/47] fix compile time error --- mediator/esmFldsExchange_sofar_mod.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 index e434e7a43..e965fe255 100644 --- a/mediator/esmFldsExchange_sofar_mod.F90 +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -302,10 +302,10 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! allocate(S_flds(2)) ! S_flds = (/'Sa_u10m', 'Sa_v10m'/) allocate(S_flds(4)) ! Sofar system !ISSUE: add option to change the export vars at runtime - S_flds = (/'Sa_u10m', ! zonal diagnosed 10m wind component - 'Sa_v10m', ! meridional diagnosed 10m wind component - 'Sa_rhoa', ! atmospheric surface density - 'Sa_astdiff' ! air minus sea surface temperature difference + S_flds = (/'Sa_u10m', & ! zonal diagnosed 10m wind component + 'Sa_v10m', & ! meridional diagnosed 10m wind component + 'Sa_rhoa', & ! atmospheric surface density + 'Sa_astdiff' & ! air minus sea surface temperature difference /) ! Sofar system with diagnosed 10m winds ! S_flds = (/'Sa_u10n', 'Sa_v10n', 'Sa_rhoa', 'Sa_astdiff'/) ! Sofar system with neutral winds do n = 1,size(S_flds) @@ -603,10 +603,10 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) ! allocate(S_flds(2)) ! S_flds = (/'Sa_u10m', 'Sa_v10m'/) allocate(S_flds(4)) ! Sofar system !ISSUE: add option to change the export vars at runtime - S_flds = (/'Sa_u10m', ! zonal diagnosed 10m wind component - 'Sa_v10m', ! meridional diagnosed 10m wind component - 'Sa_rhoa', ! atmospheric surface density - 'Sa_astdiff' ! air minus sea surface temperature difference + S_flds = (/'Sa_u10m', & ! zonal diagnosed 10m wind component + 'Sa_v10m', & ! meridional diagnosed 10m wind component + 'Sa_rhoa', & ! atmospheric surface density + 'Sa_astdiff' & ! air minus sea surface temperature difference /) ! Sofar system with diagnosed 10m winds !S_flds = (/'Sa_u10n', 'Sa_v10n', 'Sa_rhoa', 'Sa_astdiff'/) ! Sofar system with neutral winds do n = 1,size(S_flds) From 5d644f5a6606607587a34cf69d91993498b475c0 Mon Sep 17 00:00:00 2001 From: StevePny Date: Wed, 3 Jul 2024 20:47:51 +0000 Subject: [PATCH 19/47] updates to support run --- mediator/esmFldsExchange_sofar_mod.F90 | 6 ++---- mediator/med_methods_mod.F90 | 4 +++- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 index e965fe255..46d6d7eba 100644 --- a/mediator/esmFldsExchange_sofar_mod.F90 +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -114,12 +114,10 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! scalar information !===================================================================== - call NUOPC_CompAttributeGet(gcomp, name='ScalarFieldName', & - isPresent=isPresent, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='ScalarFieldName', isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then - call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", & - value=cvalue, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return do n = 1,ncomps call addfld_from(n, trim(cvalue)) diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90 index d4bdab2a7..2569578a6 100644 --- a/mediator/med_methods_mod.F90 +++ b/mediator/med_methods_mod.F90 @@ -2345,6 +2345,7 @@ subroutine med_methods_State_GetScalar(state, scalar_id, scalar_value, flds_scal real(R8), pointer :: farrayptr(:,:) real(r8) :: tmp(1) character(len=*), parameter :: subname='(med_methods_State_GetScalar)' + character(ESMF_MAXSTR) :: msgString ! Sofar added ! ---------------------------------------------- rc = ESMF_SUCCESS @@ -2367,7 +2368,8 @@ subroutine med_methods_State_GetScalar(state, scalar_id, scalar_value, flds_scal call ESMF_FieldGet(field, farrayPtr = farrayptr, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (scalar_id < 0 .or. scalar_id > flds_scalar_num) then - call ESMF_LogWrite(trim(subname)//": ERROR in scalar_id", ESMF_LOGMSG_INFO, line=__LINE__, file=u_FILE_u) + write (msgString,*) ": ERROR in scalar_id, must be between [0,flds_scalar_num]. However, scalar_id = ", scalar_id ! Sofar added + call ESMF_LogWrite(trim(subname)//trim(msgString), ESMF_LOGMSG_INFO, line=__LINE__, file=u_FILE_u) rc = ESMF_FAILURE if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return endif From a715f0e9ad66cf8bc607deb2bbda88ebd046e4fb Mon Sep 17 00:00:00 2001 From: StevePny Date: Thu, 4 Jul 2024 00:36:27 +0000 Subject: [PATCH 20/47] minor debugging udpates --- mediator/med.F90 | 3 +-- mediator/med_phases_prep_wav_mod.F90 | 11 +++++++++-- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/mediator/med.F90 b/mediator/med.F90 index 4c1e7850b..3f76c425a 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -629,8 +629,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) endif ! Obtain verbosity level - call ESMF_AttributeGet(gcomp, name="Verbosity", value=cvalue, defaultValue="max", & - convention="NUOPC", purpose="Instance", rc=rc) + call ESMF_AttributeGet(gcomp, name="Verbosity", value=cvalue, defaultValue="max", convention="NUOPC", purpose="Instance", rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (maintask) then write(logunit,'(a)')trim(subname)//": Mediator verbosity is set to "//trim(cvalue) diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90 index 93755d59c..169ba16c8 100644 --- a/mediator/med_phases_prep_wav_mod.F90 +++ b/mediator/med_phases_prep_wav_mod.F90 @@ -51,6 +51,9 @@ subroutine med_phases_prep_wav_init(gcomp, rc) !--------------------------------------- rc = ESMF_SUCCESS + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + endif ! Get the internal state nullify(is_local%wrap) @@ -58,7 +61,7 @@ subroutine med_phases_prep_wav_init(gcomp, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return if (maintask) then - write(logunit,'(a)') trim(subname)//' initializing wave export accumulation FB for ' + write(logunit,'(a)') trim(subname)//' initializing wave export accumulation FB' ! for ' end if call FB_Init(is_local%wrap%FBExpAccumWav, is_local%wrap%flds_scalar_name, & STgeom=is_local%wrap%NStateExp(compwav), STflds=is_local%wrap%NStateExp(compwav), & @@ -66,6 +69,10 @@ subroutine med_phases_prep_wav_init(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call FB_reset(is_local%wrap%FBExpAccumWav, value=czero, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + endif end subroutine med_phases_prep_wav_init @@ -87,7 +94,7 @@ subroutine med_phases_prep_wav_accum(gcomp, rc) call t_startf('MED:'//subname) if (dbug_flag > 20) then - call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//': called', ESMF_LOGMSG_INFO) end if rc = ESMF_SUCCESS call memcheck(subname, 5, maintask) From 50ebd12351e416432304c11f7aa4593536516b55 Mon Sep 17 00:00:00 2001 From: StevePny Date: Thu, 4 Jul 2024 01:18:00 +0000 Subject: [PATCH 21/47] compile time fix --- mediator/med_phases_prep_wav_mod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90 index 169ba16c8..3197de535 100644 --- a/mediator/med_phases_prep_wav_mod.F90 +++ b/mediator/med_phases_prep_wav_mod.F90 @@ -40,6 +40,7 @@ subroutine med_phases_prep_wav_init(gcomp, rc) use ESMF , only : ESMF_GridComp, ESMF_SUCCESS use med_methods_mod , only : FB_Init => med_methods_FB_init + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO ! input/output variables type(ESMF_GridComp) :: gcomp From 5b938f397315fadfe9b0dfcfa4bf861944d5b2ab Mon Sep 17 00:00:00 2001 From: StevePny Date: Thu, 4 Jul 2024 10:28:35 +0000 Subject: [PATCH 22/47] minor debugging additions --- mediator/med.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/mediator/med.F90 b/mediator/med.F90 index 3f76c425a..9bfbb0f29 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -1971,10 +1971,14 @@ subroutine DataInitialize(gcomp, rc) ! the correct timestamps, which also indicates that the actual ! data has been transferred reliably, and CMEPS can safely use it. + call ESMF_LogWrite(trim(subname)//": done first call.", ESMF_LOGMSG_INFO) + RETURN endif ! end first_call if-block + call ESMF_LogWrite(trim(subname)//": called beyond first call", ESMF_LOGMSG_INFO) + !---------------------------------------------------------- ! Create FBfrac field bundles and initialize fractions ! This has some complex dependencies on fractions from import States From 0e019ed23f2133ab51b50a889c7952219954a645 Mon Sep 17 00:00:00 2001 From: StevePny Date: Mon, 8 Jul 2024 21:56:22 +0000 Subject: [PATCH 23/47] updates to makefile fragment --- cmeps.mk | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/cmeps.mk b/cmeps.mk index 28c448632..d5ac3cc18 100644 --- a/cmeps.mk +++ b/cmeps.mk @@ -3,7 +3,18 @@ # makefile fragment for CMEPS #----------------------------------------------- +# component module name +#MED_ESMF_DEP_FRONT := MED +#MED_ESMF_DEP_SHRD_PATH := /opt/PIO/lib /tmp/CMEPS/mediator /tmp/CMEPS/shared /tmp/CMEPS/ufs /opt/libFMS/intel/32bit /opt/nceplibs/lib +#MED_ESMF_DEP_SHRD_LIBS := pioc piof cmeps shared cmeps_share + # component module name MED_ESMF_DEP_FRONT := MED -MED_ESMF_DEP_SHRD_PATH := +# component module path +MED_ESMF_DEP_INCPATH := /opt/PIO/include +# component module objects +MED_ESMF_DEP_CMPL_OBJS := /tmp/CMEPS/mediator/*.o /tmp/CMEPS/shared/*.o /tmp/CMEPS/ufs/*.o +# component object/archive list +MED_ESMF_DEP_LINK_OBJS := /tmp/CMEPS/mediator/libcmeps.a /tmp/CMEPS/shared/libshared.a /tmp/CMEPS/ufs/libcmeps_share.a +MED_ESMF_DEP_SHRD_PATH := /opt/PIO/lib /opt/libFMS/intel/32bit /opt/nceplibs/lib /tmp/CMEPS/mediator /tmp/CMEPS/shared /tmp/CMEPS/ufs MED_ESMF_DEP_SHRD_LIBS := pioc piof cmeps shared cmeps_share From 2c751cb62d42ca70b96c45a3ab50c1d8c8b8f553 Mon Sep 17 00:00:00 2001 From: StevePny Date: Tue, 9 Jul 2024 06:40:44 +0000 Subject: [PATCH 24/47] wildcard expansion on cmeps .o files --- cmeps.mk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cmeps.mk b/cmeps.mk index d5ac3cc18..c0fa14abe 100644 --- a/cmeps.mk +++ b/cmeps.mk @@ -13,7 +13,7 @@ MED_ESMF_DEP_FRONT := MED # component module path MED_ESMF_DEP_INCPATH := /opt/PIO/include # component module objects -MED_ESMF_DEP_CMPL_OBJS := /tmp/CMEPS/mediator/*.o /tmp/CMEPS/shared/*.o /tmp/CMEPS/ufs/*.o +MED_ESMF_DEP_CMPL_OBJS := $(/tmp/CMEPS/mediator/*.o) $(/tmp/CMEPS/shared/*.o) $(/tmp/CMEPS/ufs/*.o) # component object/archive list MED_ESMF_DEP_LINK_OBJS := /tmp/CMEPS/mediator/libcmeps.a /tmp/CMEPS/shared/libshared.a /tmp/CMEPS/ufs/libcmeps_share.a MED_ESMF_DEP_SHRD_PATH := /opt/PIO/lib /opt/libFMS/intel/32bit /opt/nceplibs/lib /tmp/CMEPS/mediator /tmp/CMEPS/shared /tmp/CMEPS/ufs From 343a760c8852f3ca3060a98a46d460f513d5caa8 Mon Sep 17 00:00:00 2001 From: StevePny Date: Tue, 9 Jul 2024 07:34:06 +0000 Subject: [PATCH 25/47] tested cmeps.mk --- cmeps.mk | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/cmeps.mk b/cmeps.mk index c0fa14abe..bb5a0a4b0 100644 --- a/cmeps.mk +++ b/cmeps.mk @@ -3,18 +3,11 @@ # makefile fragment for CMEPS #----------------------------------------------- -# component module name -#MED_ESMF_DEP_FRONT := MED -#MED_ESMF_DEP_SHRD_PATH := /opt/PIO/lib /tmp/CMEPS/mediator /tmp/CMEPS/shared /tmp/CMEPS/ufs /opt/libFMS/intel/32bit /opt/nceplibs/lib -#MED_ESMF_DEP_SHRD_LIBS := pioc piof cmeps shared cmeps_share - # component module name MED_ESMF_DEP_FRONT := MED # component module path -MED_ESMF_DEP_INCPATH := /opt/PIO/include -# component module objects -MED_ESMF_DEP_CMPL_OBJS := $(/tmp/CMEPS/mediator/*.o) $(/tmp/CMEPS/shared/*.o) $(/tmp/CMEPS/ufs/*.o) +MED_ESMF_DEP_INCPATH := /opt/PIO/include /tmp/CMEPS/mediator /tmp/CMEPS/shared /tmp/CMEPS/ufs # component object/archive list MED_ESMF_DEP_LINK_OBJS := /tmp/CMEPS/mediator/libcmeps.a /tmp/CMEPS/shared/libshared.a /tmp/CMEPS/ufs/libcmeps_share.a -MED_ESMF_DEP_SHRD_PATH := /opt/PIO/lib /opt/libFMS/intel/32bit /opt/nceplibs/lib /tmp/CMEPS/mediator /tmp/CMEPS/shared /tmp/CMEPS/ufs +MED_ESMF_DEP_SHRD_PATH := /opt/PIO/lib /tmp/CMEPS/mediator /tmp/CMEPS/shared /tmp/CMEPS/ufs /opt/libFMS/intel/32bit /opt/nceplibs/lib MED_ESMF_DEP_SHRD_LIBS := pioc piof cmeps shared cmeps_share From cd84cdbcf67f0685dbca4ff5cdbc7aa815c0d885 Mon Sep 17 00:00:00 2001 From: StevePny Date: Tue, 16 Jul 2024 18:25:46 +0000 Subject: [PATCH 26/47] setup coupling modes test, awo, ao --- mediator/esmFldsExchange_sofar_mod.F90 | 339 +++++++++++-------------- 1 file changed, 153 insertions(+), 186 deletions(-) diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 index 46d6d7eba..d906fb3c8 100644 --- a/mediator/esmFldsExchange_sofar_mod.F90 +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -153,7 +153,7 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) !---------------------------------------------------------- ! from med: ocean albedos (not sent to the ATM in UFS). !---------------------------------------------------------- - if (trim(coupling_mode) == 'sofar.mom6') then + if (trim(coupling_mode) == 'sofar.awo' .or. (trim(coupling_mode) == 'sofar.ao') then if (phase == 'advertise') then call addfld_ocnalb('So_avsdr') call addfld_ocnalb('So_avsdf') @@ -170,28 +170,24 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to atm: surface temperatures from ocn ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar') then - allocate(S_flds(1)) - S_flds = (/'So_t'/) ! sea_surface_temperature - ! Sofar system: add surface temperature, or add NSST computation to mediator - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - call addfld_from(compocn, trim(fldname)) - call addfld_to(compatm, trim(fldname)) - end do - deallocate(S_flds) - else + if (trim(coupling_mode) == 'sofar.awo' .or. (trim(coupling_mode) == 'sofar.ao') then allocate(S_flds(3)) S_flds = (/'So_t', & ! sea_surface_temperature 'So_u', & ! surface zonal current 'So_v'/) ! surface meridional current - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - call addfld_from(compocn, trim(fldname)) - call addfld_to(compatm, trim(fldname)) - end do - deallocate(S_flds) + elseif (trim(coupling_mode) == 'sofar.test') then + allocate(S_flds(1)) + S_flds = (/'So_t'/) ! sea_surface_temperature + ! Sofar system: add surface temperature, or add NSST computation to mediator + else + allocate(S_flds(0)) end if + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compocn, trim(fldname)) + call addfld_to(compatm, trim(fldname)) + end do + if (allocated(S_flds)) deallocate(S_flds) end if ! --------------------------------------------------------------------- @@ -221,73 +217,69 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to ocn: state fields ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar') then - allocate(S_flds(6)) - S_flds = (/'Sa_u10m', & ! inst_zonal_wind_height10m - 'Sa_v10m', & ! inst_merid_wind_height10m - 'Sa_t2m ', & ! inst_temp_height2m - 'Sa_q2m ', & ! inst_spec_humid_height2m - 'Sa_pslv', & ! inst_pres_height_surface - 'Sa_tskn' /) ! inst_temp_height_surface - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - call addfld_from(compatm, trim(fldname)) - call addfld_to(compocn, trim(fldname)) - end do - deallocate(S_flds) - else - allocate(S_flds(1)) - S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - call addfld_from(compatm, trim(fldname)) - call addfld_to(compocn, trim(fldname)) - end do - deallocate(S_flds) - end if - end if + if (trim(coupling_mode) == 'sofar.awo' .or. trim(coupling_mode) == 'sofar.ao') then + allocate(S_flds(1)) + S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface + elseif (trim(coupling_mode) == 'sofar.test') then + allocate(S_flds(1)) + S_flds = (/'Sa_t2m ' /) ! inst_temp_height2m + elseif (trim(coupling_mode) == 'sofar.hycom') + allocate(S_flds(6)) + S_flds = (/'Sa_u10m', & ! inst_zonal_wind_height10m + 'Sa_v10m', & ! inst_merid_wind_height10m + 'Sa_t2m ', & ! inst_temp_height2m + 'Sa_q2m ', & ! inst_spec_humid_height2m + 'Sa_pslv', & ! inst_pres_height_surface + 'Sa_tskn' /) ! inst_temp_height_surface + else + allocate(S_flds(0)) + endif + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compatm, trim(fldname)) + call addfld_to(compocn, trim(fldname)) + enddo + if (allocated(S_flds)) deallocate(S_flds) + endif ! --------------------------------------------------------------------- ! to ocn: flux fields ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar') then - allocate(F_flds(7,2)) - F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm - F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm - F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate - F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx - F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx - F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx - F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx - do n = 1,size(F_flds,1) - fldname1 = trim(F_flds(n,1)) - fldname2 = trim(F_flds(n,2)) - call addfld_from(compatm, trim(fldname1)) - call addfld_to(compocn, trim(fldname2)) - end do - deallocate(F_flds) - else - allocate(F_flds(10,2)) - F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm - F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm - F_flds(3 ,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate - F_flds(4 ,:) = (/'Faxa_lwnet ','Foxx_lwnet '/) ! inst_net_lw_flx - F_flds(5 ,:) = (/'Faxa_sen ','Foxx_sen '/) ! inst_sensi_heat_flx - F_flds(6 ,:) = (/'Faxa_evap ','Foxx_evap '/) ! inst_evap_rate - F_flds(7 ,:) = (/'Faxa_swndr ','Foxx_swnet_idr'/) ! inst_down_sw_ir_dir_flx - F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx - F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx - F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx - do n = 1,size(F_flds,1) - fldname1 = trim(F_flds(n,1)) - fldname2 = trim(F_flds(n,2)) - call addfld_from(compatm, trim(fldname1)) - call addfld_to(compocn, trim(fldname2)) - end do - deallocate(F_flds) - end if - end if + if (trim(coupling_mode) == 'sofar.awo' .or. (trim(coupling_mode) == 'sofar.ao') then + allocate(F_flds(7,2)) + F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm + F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm + F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate + F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx + F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx + F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx + F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx + elseif (trim(coupling_mode) == 'sofar.test') then + print *, "esmFldsExchange_sofar_mod.F90:: coupling_mode==sofar.test, Skip fluxes..." + elseif (trim(coupling_mode) == 'sofar.hycom') then + allocate(F_flds(10,2)) + F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm + F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm + F_flds(3 ,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate + F_flds(4 ,:) = (/'Faxa_lwnet ','Foxx_lwnet '/) ! inst_net_lw_flx + F_flds(5 ,:) = (/'Faxa_sen ','Foxx_sen '/) ! inst_sensi_heat_flx + F_flds(6 ,:) = (/'Faxa_evap ','Foxx_evap '/) ! inst_evap_rate + F_flds(7 ,:) = (/'Faxa_swndr ','Foxx_swnet_idr'/) ! inst_down_sw_ir_dir_flx + F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx + F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx + F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx + else + allocate(F_flds(0,1)) + endif + do n = 1,size(F_flds,1) + fldname1 = trim(F_flds(n,1)) + fldname2 = trim(F_flds(n,2)) + call addfld_from(compatm, trim(fldname1)) + call addfld_to(compocn, trim(fldname2)) + end do + if (allocated(F_flds)) deallocate(F_flds) + endif !===================================================================== ! FIELDS TO WAVE (compwav) @@ -297,22 +289,20 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to wav: 10-m wind components ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%wav_present) then -! allocate(S_flds(2)) -! S_flds = (/'Sa_u10m', 'Sa_v10m'/) - allocate(S_flds(4)) ! Sofar system !ISSUE: add option to change the export vars at runtime - S_flds = (/'Sa_u10m', & ! zonal diagnosed 10m wind component - 'Sa_v10m', & ! meridional diagnosed 10m wind component - 'Sa_rhoa', & ! atmospheric surface density - 'Sa_astdiff' & ! air minus sea surface temperature difference - /) ! Sofar system with diagnosed 10m winds -! S_flds = (/'Sa_u10n', 'Sa_v10n', 'Sa_rhoa', 'Sa_astdiff'/) ! Sofar system with neutral winds - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - call addfld_from(compatm, trim(fldname)) - call addfld_to(compwav, trim(fldname)) - end do - deallocate(S_flds) - end if + allocate(S_flds(4)) ! Sofar system !ISSUE: add option to change the export vars at runtime + S_flds = (/'Sa_u10m', & ! zonal diagnosed 10m wind component + 'Sa_v10m', & ! meridional diagnosed 10m wind component + 'Sa_rhoa', & ! atmospheric surface density + 'Sa_astdiff' & ! air minus sea surface temperature difference + /) ! Sofar system with diagnosed 10m winds +! S_flds = (/'Sa_u10n', 'Sa_v10n', 'Sa_rhoa', 'Sa_astdiff'/) ! Sofar system with neutral winds + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compatm, trim(fldname)) + call addfld_to(compwav, trim(fldname)) + enddo + deallocate(S_flds) + endif call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) @@ -430,39 +420,32 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) ! to atm: sea surface temperature ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar') then - allocate(S_flds(1)) - S_flds = (/'So_t'/) ! sea_surface_temperature - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compocn,compocn),trim(fldname),rc=rc) & - ) then - call addmap_from(compocn, trim(fldname), compatm, & - mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%ocn2atm_smap) - call addmrg_to(compatm, trim(fldname), & - mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') - end if - end do - deallocate(S_flds) - else + if (trim(coupling_mode) == 'sofar.awo' .or. trim(coupling_mode) == 'sofar.ao') then allocate(S_flds(3)) S_flds = (/'So_t', & ! sea_surface_temperature 'So_u', & ! surface zonal current 'So_v'/) ! surface meridional current - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compocn,compocn),trim(fldname),rc=rc) & - ) then - call addmap_from(compocn, trim(fldname), compatm, & + elseif (trim(coupling_mode) == 'sofar.test') then + allocate(S_flds(1)) + S_flds = (/'So_t'/) ! sea_surface_temperature + elseif (trim(coupling_mode) == 'sofar.hycom') then + allocate(S_flds(1)) + S_flds = (/'So_t'/) ! sea_surface_temperature + else + allocate(S_flds(0)) + endif + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn),trim(fldname),rc=rc) & + ) then + call addmap_from(compocn, trim(fldname), compatm, & mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%ocn2atm_smap) - call addmrg_to(compatm, trim(fldname), & + call addmrg_to(compatm, trim(fldname), & mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') - end if - end do - deallocate(S_flds) - end if + endif + enddo + deallocate(S_flds) end if ! --------------------------------------------------------------------- @@ -485,8 +468,8 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%wav2atm_smap) call addmrg_to(compatm, trim(fldname), & mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') - end if - end do + endif + enddo deallocate(S_flds) end if @@ -498,7 +481,13 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) ! to ocn: state fields ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar') then + if (trim(coupling_mode) == 'sofar.awo' .or. trim(coupling_mode) == 'sofar.ao') then + allocate(S_flds(1)) + S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface + elseif (trim(coupling_mode) == 'sofar.test') then + allocate(S_flds(1)) + S_flds = (/'Sa_t2m ' /) ! inst_temp_height2m + elseif (trim(coupling_mode) == 'sofar.hycom') then allocate(S_flds(6)) S_flds = (/'Sa_u10m', & ! inst_zonal_wind_height10m 'Sa_v10m', & ! inst_merid_wind_height10m @@ -506,63 +495,28 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) 'Sa_q2m ', & ! inst_spec_humid_height2m 'Sa_pslv', & ! inst_pres_height_surface 'Sa_tskn' /) ! inst_temp_height_surface - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname),rc=rc) & - ) then - call addmap_from(compatm, trim(fldname), compocn, & - mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%atm2ocn_smap) - call addmrg_to(compocn, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') - end if - end do - deallocate(S_flds) else - allocate(S_flds(1)) - S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname),rc=rc) & - ) then - call addmap_from(compatm, trim(fldname), compocn, & + allocate(S_flds(0)) + endif + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname),rc=rc) & + ) then + call addmap_from(compatm, trim(fldname), compocn, & mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%atm2ocn_smap) - call addmrg_to(compocn, trim(fldname), & + call addmrg_to(compocn, trim(fldname), & mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') - end if - end do - deallocate(S_flds) - end if - end if + endif + enddo + if (allocated(S_flds)) deallocate(S_flds) + endif ! --------------------------------------------------------------------- ! to ocn: flux fields ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar') then - allocate(F_flds(7,2)) - F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm - F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm - F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate - F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx - F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx - F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx - F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx - do n = 1,size(F_flds,1) - fldname1 = trim(F_flds(n,1)) - fldname2 = trim(F_flds(n,2)) - if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname2),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname1),rc=rc) & - ) then - call addmap_from(compatm, trim(fldname1), compocn, & - mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%atm2ocn_smap) - call addmrg_to(compocn, trim(fldname2), & - mrg_from=compatm, mrg_fld=trim(fldname1), mrg_type='copy') - end if - end do - deallocate(F_flds) - else + if (trim(coupling_mode) == 'sofar.awo' .or. trim(coupling_mode) == 'sofar.ao') then allocate(F_flds(10,2)) F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm @@ -574,20 +528,33 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx - do n = 1,size(F_flds,1) - fldname1 = trim(F_flds(n,1)) - fldname2 = trim(F_flds(n,2)) - if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname2),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname1),rc=rc) & + elseif (trim(coupling_mode) == 'sofar.test') then + print *, "esmFldsExchange_sofar_mod.F90:: coupling_mode==sofar.test, Skip fluxes..." + elseif (trim(coupling_mode) == 'sofar.hycom') then + allocate(F_flds(7,2)) + F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm + F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm + F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate + F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx + F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx + F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx + F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx + else + allocate(F_flds(0,1)) + endif + do n = 1,size(F_flds,1) + fldname1 = trim(F_flds(n,1)) + fldname2 = trim(F_flds(n,2)) + if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname2),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname1),rc=rc) & ) then - call addmap_from(compatm, trim(fldname1), compocn, & + call addmap_from(compatm, trim(fldname1), compocn, & mapfillv_bilnr, sofar_attr%mapnorm, sofar_attr%atm2ocn_smap) - call addmrg_to(compocn, trim(fldname2), & + call addmrg_to(compocn, trim(fldname2), & mrg_from=compatm, mrg_fld=trim(fldname1), mrg_type='copy') - end if - end do - deallocate(F_flds) - end if + endif + enddo + deallocate(F_flds) end if !===================================================================== From 33c6d383f7aeb17c26e433179f9c15eac6ee6d11 Mon Sep 17 00:00:00 2001 From: StevePny Date: Tue, 16 Jul 2024 21:41:47 +0000 Subject: [PATCH 27/47] change to neutral winds --- mediator/esmFldsExchange_sofar_mod.F90 | 74 +++++++++++++------------- 1 file changed, 36 insertions(+), 38 deletions(-) diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 index d906fb3c8..fb01e5c6c 100644 --- a/mediator/esmFldsExchange_sofar_mod.F90 +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -146,14 +146,14 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to med: frac from components !---------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then ! Sofar system: added - call addfld_to(compatm, 'So_ofrac') -! call addfld_from(compatm , 'Sa_ofrac') ! Sofar system: added +! call addfld_to(compatm, 'So_ofrac') ! Sofar system: added + call addfld_from(compatm , 'Sa_oceanfrac') endif ! Sofar system: added !---------------------------------------------------------- ! from med: ocean albedos (not sent to the ATM in UFS). !---------------------------------------------------------- - if (trim(coupling_mode) == 'sofar.awo' .or. (trim(coupling_mode) == 'sofar.ao') then + if (trim(coupling_mode) == 'sofar') then if (phase == 'advertise') then call addfld_ocnalb('So_avsdr') call addfld_ocnalb('So_avsdf') @@ -170,11 +170,11 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to atm: surface temperatures from ocn ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar.awo' .or. (trim(coupling_mode) == 'sofar.ao') then - allocate(S_flds(3)) - S_flds = (/'So_t', & ! sea_surface_temperature - 'So_u', & ! surface zonal current - 'So_v'/) ! surface meridional current + if (trim(coupling_mode) == 'sofar') then + allocate(S_flds(1)) + S_flds = (/'So_t'/) ! sea_surface_temperature + ! 'So_u', & ! surface zonal current + ! 'So_v'/) ! surface meridional current elseif (trim(coupling_mode) == 'sofar.test') then allocate(S_flds(1)) S_flds = (/'So_t'/) ! sea_surface_temperature @@ -217,7 +217,7 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to ocn: state fields ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar.awo' .or. trim(coupling_mode) == 'sofar.ao') then + if (trim(coupling_mode) == 'sofar') then allocate(S_flds(1)) S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface elseif (trim(coupling_mode) == 'sofar.test') then @@ -225,8 +225,8 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) S_flds = (/'Sa_t2m ' /) ! inst_temp_height2m elseif (trim(coupling_mode) == 'sofar.hycom') allocate(S_flds(6)) - S_flds = (/'Sa_u10m', & ! inst_zonal_wind_height10m - 'Sa_v10m', & ! inst_merid_wind_height10m + S_flds = (/'Sa_u10n', & ! inst_zonal_wind_height10m + 'Sa_v10n', & ! inst_merid_wind_height10m 'Sa_t2m ', & ! inst_temp_height2m 'Sa_q2m ', & ! inst_spec_humid_height2m 'Sa_pslv', & ! inst_pres_height_surface @@ -246,18 +246,7 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to ocn: flux fields ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar.awo' .or. (trim(coupling_mode) == 'sofar.ao') then - allocate(F_flds(7,2)) - F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm - F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm - F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate - F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx - F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx - F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx - F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx - elseif (trim(coupling_mode) == 'sofar.test') then - print *, "esmFldsExchange_sofar_mod.F90:: coupling_mode==sofar.test, Skip fluxes..." - elseif (trim(coupling_mode) == 'sofar.hycom') then + if (trim(coupling_mode) == 'sofar') then allocate(F_flds(10,2)) F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm @@ -269,6 +258,17 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx + elseif (trim(coupling_mode) == 'sofar.test') then + print *, "esmFldsExchange_sofar_mod.F90:: coupling_mode==sofar.test, Skip fluxes..." + elseif (trim(coupling_mode) == 'sofar.hycom') then + allocate(F_flds(7,2)) + F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm + F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm + F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate + F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx + F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx + F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx + F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx else allocate(F_flds(0,1)) endif @@ -290,12 +290,11 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%wav_present) then allocate(S_flds(4)) ! Sofar system !ISSUE: add option to change the export vars at runtime - S_flds = (/'Sa_u10m', & ! zonal diagnosed 10m wind component - 'Sa_v10m', & ! meridional diagnosed 10m wind component + S_flds = (/'Sa_u10n', & ! zonal diagnosed 10m neutral wind component + 'Sa_v10n', & ! meridional diagnosed 10m neutral wind component 'Sa_rhoa', & ! atmospheric surface density 'Sa_astdiff' & ! air minus sea surface temperature difference /) ! Sofar system with diagnosed 10m winds -! S_flds = (/'Sa_u10n', 'Sa_v10n', 'Sa_rhoa', 'Sa_astdiff'/) ! Sofar system with neutral winds do n = 1,size(S_flds) fldname = trim(S_flds(n)) call addfld_from(compatm, trim(fldname)) @@ -420,11 +419,11 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) ! to atm: sea surface temperature ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar.awo' .or. trim(coupling_mode) == 'sofar.ao') then - allocate(S_flds(3)) - S_flds = (/'So_t', & ! sea_surface_temperature - 'So_u', & ! surface zonal current - 'So_v'/) ! surface meridional current + if (trim(coupling_mode) == 'sofar') then + allocate(S_flds(1)) + S_flds = (/'So_t'/) ! sea_surface_temperature + ! 'So_u', & ! surface zonal current + ! 'So_v'/) ! surface meridional current elseif (trim(coupling_mode) == 'sofar.test') then allocate(S_flds(1)) S_flds = (/'So_t'/) ! sea_surface_temperature @@ -481,7 +480,7 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) ! to ocn: state fields ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar.awo' .or. trim(coupling_mode) == 'sofar.ao') then + if (trim(coupling_mode) == 'sofar') then allocate(S_flds(1)) S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface elseif (trim(coupling_mode) == 'sofar.test') then @@ -489,8 +488,8 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) S_flds = (/'Sa_t2m ' /) ! inst_temp_height2m elseif (trim(coupling_mode) == 'sofar.hycom') then allocate(S_flds(6)) - S_flds = (/'Sa_u10m', & ! inst_zonal_wind_height10m - 'Sa_v10m', & ! inst_merid_wind_height10m + S_flds = (/'Sa_u10n', & ! inst_zonal_wind_height10m + 'Sa_v10n', & ! inst_merid_wind_height10m 'Sa_t2m ', & ! inst_temp_height2m 'Sa_q2m ', & ! inst_spec_humid_height2m 'Sa_pslv', & ! inst_pres_height_surface @@ -516,7 +515,7 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) ! to ocn: flux fields ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar.awo' .or. trim(coupling_mode) == 'sofar.ao') then + if (trim(coupling_mode) == 'sofar') then allocate(F_flds(10,2)) F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm @@ -568,12 +567,11 @@ subroutine esmFldsExchange_sofar_init(gcomp, phase, rc) ! allocate(S_flds(2)) ! S_flds = (/'Sa_u10m', 'Sa_v10m'/) allocate(S_flds(4)) ! Sofar system !ISSUE: add option to change the export vars at runtime - S_flds = (/'Sa_u10m', & ! zonal diagnosed 10m wind component - 'Sa_v10m', & ! meridional diagnosed 10m wind component + S_flds = (/'Sa_u10n', & ! zonal diagnosed 10m neutral wind component + 'Sa_v10n', & ! meridional diagnosed 10m neutral wind component 'Sa_rhoa', & ! atmospheric surface density 'Sa_astdiff' & ! air minus sea surface temperature difference /) ! Sofar system with diagnosed 10m winds - !S_flds = (/'Sa_u10n', 'Sa_v10n', 'Sa_rhoa', 'Sa_astdiff'/) ! Sofar system with neutral winds do n = 1,size(S_flds) fldname = trim(S_flds(n)) if (fldchk(is_local%wrap%FBexp(compwav),trim(fldname),rc=rc) .and. & From 2a6620418f7eed3e4a28d8911c8f8d5683042037 Mon Sep 17 00:00:00 2001 From: StevePny Date: Wed, 17 Jul 2024 10:42:41 +0000 Subject: [PATCH 28/47] compile time bug fix missing then --- mediator/esmFldsExchange_sofar_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 index fb01e5c6c..f76eb374a 100644 --- a/mediator/esmFldsExchange_sofar_mod.F90 +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -223,7 +223,7 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) elseif (trim(coupling_mode) == 'sofar.test') then allocate(S_flds(1)) S_flds = (/'Sa_t2m ' /) ! inst_temp_height2m - elseif (trim(coupling_mode) == 'sofar.hycom') + elseif (trim(coupling_mode) == 'sofar.hycom') then allocate(S_flds(6)) S_flds = (/'Sa_u10n', & ! inst_zonal_wind_height10m 'Sa_v10n', & ! inst_merid_wind_height10m From 7e795b2c14b3189e8d4958a32fd123b4f33c2c48 Mon Sep 17 00:00:00 2001 From: StevePny Date: Sat, 20 Jul 2024 00:29:05 +0000 Subject: [PATCH 29/47] add more general options for sofar runtime --- mediator/esmFldsExchange_sofar_mod.F90 | 118 ++++++++++++++++++------- 1 file changed, 84 insertions(+), 34 deletions(-) diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 index f76eb374a..378138176 100644 --- a/mediator/esmFldsExchange_sofar_mod.F90 +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -153,7 +153,7 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) !---------------------------------------------------------- ! from med: ocean albedos (not sent to the ATM in UFS). !---------------------------------------------------------- - if (trim(coupling_mode) == 'sofar') then + if (trim(coupling_mode(1:5)) == 'sofar') then if (phase == 'advertise') then call addfld_ocnalb('So_avsdr') call addfld_ocnalb('So_avsdf') @@ -170,15 +170,9 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to atm: surface temperatures from ocn ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar') then + if (trim(coupling_mode(1:5)) == 'sofar') then allocate(S_flds(1)) S_flds = (/'So_t'/) ! sea_surface_temperature - ! 'So_u', & ! surface zonal current - ! 'So_v'/) ! surface meridional current - elseif (trim(coupling_mode) == 'sofar.test') then - allocate(S_flds(1)) - S_flds = (/'So_t'/) ! sea_surface_temperature - ! Sofar system: add surface temperature, or add NSST computation to mediator else allocate(S_flds(0)) end if @@ -196,7 +190,6 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) if (sofar_attr%atm_present .and. sofar_attr%wav_present) then allocate(S_flds(1)) !allocate(S_flds(2)) ! Sofar system !ISSUE: add option to change the export vars at runtime -! S_flds = (/'Sw_z0rlen'/) ! wave_z0_roughness_length S_flds = (/'Sw_charno'/) ! Charnock parameter !S_flds = (/'Sw_z0rlen', & ! wave_z0_roughness_length ! Sofar system ! 'Sw_charno', & ! Charnock parameter ! Sofar system @@ -217,20 +210,9 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to ocn: state fields ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar') then + if (trim(coupling_mode(1:5)) == 'sofar') then allocate(S_flds(1)) S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface - elseif (trim(coupling_mode) == 'sofar.test') then - allocate(S_flds(1)) - S_flds = (/'Sa_t2m ' /) ! inst_temp_height2m - elseif (trim(coupling_mode) == 'sofar.hycom') then - allocate(S_flds(6)) - S_flds = (/'Sa_u10n', & ! inst_zonal_wind_height10m - 'Sa_v10n', & ! inst_merid_wind_height10m - 'Sa_t2m ', & ! inst_temp_height2m - 'Sa_q2m ', & ! inst_spec_humid_height2m - 'Sa_pslv', & ! inst_pres_height_surface - 'Sa_tskn' /) ! inst_temp_height_surface else allocate(S_flds(0)) endif @@ -246,7 +228,9 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to ocn: flux fields ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%ocn_present) then - if (trim(coupling_mode) == 'sofar') then + if (trim(coupling_mode) == 'sofar.nofluxes') then + print *, "esmFldsExchange_sofar_mod.F90:: coupling_mode==sofar.test, Skip fluxes..." + elseif (trim(coupling_mode(1:5)) == 'sofar') then allocate(F_flds(10,2)) F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm @@ -258,17 +242,6 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx - elseif (trim(coupling_mode) == 'sofar.test') then - print *, "esmFldsExchange_sofar_mod.F90:: coupling_mode==sofar.test, Skip fluxes..." - elseif (trim(coupling_mode) == 'sofar.hycom') then - allocate(F_flds(7,2)) - F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm - F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm - F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate - F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx - F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx - F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx - F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx else allocate(F_flds(0,1)) endif @@ -281,12 +254,46 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) if (allocated(F_flds)) deallocate(F_flds) endif + ! --------------------------------------------------------------------- + ! to ocn: wave parameters + ! --------------------------------------------------------------------- + if (sofar_attr%wav_present .and. sofar_attr%ocn_present) then + ! See here for fields that the ocean model can actually accept: + ! https://github.com/NOAA-GFDL/MOM6/blob/2f2b7905c08e95a729d3dd3f8b02e0a0bed10602/config_src/drivers/nuopc_cap/mom_cap.F90#L787 + if (trim(coupling_mode) == 'sofar.wav2ocn') then + S_flds = (/'Sw_uscurr', & ! Stokes Drift 3D + 'Sw_vscurr', & ! + 'Sw_x1pstk', & ! Partitioned Stokes Drift 3 2D fields + 'Sw_y1pstk', & ! + 'Sw_x2pstk', & ! + 'Sw_y2pstk', & ! + 'Sw_x3pstk', & ! + 'Sw_y3pstk', & ! + 'Sw_wbcuru', & ! Bottom Currents + 'Sw_wbcurv', & ! + 'Sw_wbcurp', & ! + 'Sw_wavsuu', & ! Radiation stresses 2D + 'Sw_wavsuv', & ! + 'Sw_wavsvv' & ! + /) + else + allocate(S_flds(0)) + endif + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compwav, trim(fldname)) + call addfld_to(compocn, trim(fldname)) + enddo + deallocate(S_flds) + if (allocated(F_flds)) deallocate(F_flds) + endif + !===================================================================== ! FIELDS TO WAVE (compwav) !===================================================================== ! --------------------------------------------------------------------- - ! to wav: 10-m wind components + ! to wav: 10-m wind components, air surface density, and air-sea temp difference ! --------------------------------------------------------------------- if (sofar_attr%atm_present .and. sofar_attr%wav_present) then allocate(S_flds(4)) ! Sofar system !ISSUE: add option to change the export vars at runtime @@ -303,6 +310,49 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) deallocate(S_flds) endif + ! --------------------------------------------------------------------- + ! to wav: ocean surface components + ! --------------------------------------------------------------------- + if (sofar_attr%ocn_present .and. sofar_attr%wav_present) then + if (trim(coupling_mode) == 'sofar.ocn2wav') + allocate(S_flds(3)) ! Sofar system !ISSUE: add option to change the export vars at runtime + S_flds = (/'So_u', & ! zonal ocean surface current + 'So_v', & ! meridional ocean surface current + 'So_ssh' & ! Sea surface height + ! 'So_rhoo', & ! ocean surface density + ! 'So_t' & ! ocean surface temperature (eventually pass gustiness from atm to wav) + /) + else + allocate(S_flds(0)) + endif + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compocn, trim(fldname)) + call addfld_to(compwav, trim(fldname)) + enddo + deallocate(S_flds) + endif + + ! --------------------------------------------------------------------- + ! to wav: sea ice (not yet supported) + ! --------------------------------------------------------------------- + if (sofar_attr%ocn_present .and. sofar_attr%wav_present) then + if (trim(coupling_mode) == 'sofar.ice2wav') + allocate(S_flds(1)) ! Sofar system !ISSUE: add option to change the export vars at runtime + S_flds = (/'Si_seaice' ! Sea ice fraction / concentration + /) + else + allocate(S_flds(0)) + endif + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compice, trim(fldname)) + call addfld_to(compwav, trim(fldname)) + enddo + deallocate(S_flds) + endif + + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) end subroutine esmFldsExchange_sofar_advt From 855193e9a1ba3924617acbb181b977ee1abe7921 Mon Sep 17 00:00:00 2001 From: StevePny Date: Sat, 20 Jul 2024 06:14:05 +0000 Subject: [PATCH 30/47] add missing compice declaration --- mediator/esmFldsExchange_sofar_mod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 index 378138176..24423f30b 100644 --- a/mediator/esmFldsExchange_sofar_mod.F90 +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -11,6 +11,7 @@ module esmFldsExchange_sofar_mod use med_internalstate_mod , only : compatm use med_internalstate_mod , only : compocn use med_internalstate_mod , only : compwav + use med_internalstate_mod , only : compice ! Sofar added: for eventual coupling of cice6 use med_internalstate_mod , only : ncomps use med_internalstate_mod , only : coupling_mode use esmFlds , only : addfld_ocnalb => med_fldList_addfld_ocnalb From 9d59faefdc0d82b70b3d5b651e842872362ec4b6 Mon Sep 17 00:00:00 2001 From: StevePny Date: Sat, 20 Jul 2024 06:20:07 +0000 Subject: [PATCH 31/47] compile time fixes --- mediator/esmFldsExchange_sofar_mod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 index 24423f30b..791318859 100644 --- a/mediator/esmFldsExchange_sofar_mod.F90 +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -315,7 +315,7 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to wav: ocean surface components ! --------------------------------------------------------------------- if (sofar_attr%ocn_present .and. sofar_attr%wav_present) then - if (trim(coupling_mode) == 'sofar.ocn2wav') + if (trim(coupling_mode) == 'sofar.ocn2wav') then allocate(S_flds(3)) ! Sofar system !ISSUE: add option to change the export vars at runtime S_flds = (/'So_u', & ! zonal ocean surface current 'So_v', & ! meridional ocean surface current @@ -338,9 +338,9 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) ! to wav: sea ice (not yet supported) ! --------------------------------------------------------------------- if (sofar_attr%ocn_present .and. sofar_attr%wav_present) then - if (trim(coupling_mode) == 'sofar.ice2wav') + if (trim(coupling_mode) == 'sofar.ice2wav') then allocate(S_flds(1)) ! Sofar system !ISSUE: add option to change the export vars at runtime - S_flds = (/'Si_seaice' ! Sea ice fraction / concentration + S_flds = (/'Si_seaice' & ! Sea ice fraction / concentration /) else allocate(S_flds(0)) From 2337f4cc945bf6e550baf0a56fa499b6185f0f88 Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Wed, 5 Mar 2025 08:07:07 +0000 Subject: [PATCH 32/47] Add defaultMasks for coupling_mode=sofar --- mediator/esmFldsExchange_sofar_mod.F90 | 6 +++--- mediator/med.F90 | 2 +- mediator/med_internalstate_mod.F90 | 3 +++ mediator/med_map_mod.F90 | 5 +++++ 4 files changed, 12 insertions(+), 4 deletions(-) diff --git a/mediator/esmFldsExchange_sofar_mod.F90 b/mediator/esmFldsExchange_sofar_mod.F90 index 791318859..e9a94ff87 100644 --- a/mediator/esmFldsExchange_sofar_mod.F90 +++ b/mediator/esmFldsExchange_sofar_mod.F90 @@ -154,13 +154,13 @@ subroutine esmFldsExchange_sofar_advt(gcomp, phase, rc) !---------------------------------------------------------- ! from med: ocean albedos (not sent to the ATM in UFS). !---------------------------------------------------------- - if (trim(coupling_mode(1:5)) == 'sofar') then - if (phase == 'advertise') then + if (sofar_attr%ocn_present) then + if (trim(coupling_mode(1:5)) == 'sofar') then call addfld_ocnalb('So_avsdr') call addfld_ocnalb('So_avsdf') call addfld_ocnalb('So_anidr') call addfld_ocnalb('So_anidf') - end if + end if end if !===================================================================== diff --git a/mediator/med.F90 b/mediator/med.F90 index 9bfbb0f29..5e45ca9e7 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -12,7 +12,7 @@ module MED ! the run sequence provided by freeFormat, this loop becomes the driver ! loop level directly. Therefore, setting the timeStep or runDuration ! for the outer most time loop results in modifying the driver clock - ! itself. However, for cases with cocnatenated loops on the upper level + ! itself. However, for cases with concatenated loops on the upper level ! of the run sequence in freeFormat, a single outer loop is added ! automatically during ingestion, and the driver clock is used for this ! loop instead. diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90 index d09903be5..d0288f87d 100644 --- a/mediator/med_internalstate_mod.F90 +++ b/mediator/med_internalstate_mod.F90 @@ -671,6 +671,9 @@ subroutine med_internalstate_defaultmasks(gcomp, rc) if ( trim(coupling_mode) == 'hafs') then if (is_local%wrap%comp_present(compatm)) defaultMasks(compatm,1) = 1 endif + if ( trim(coupling_mode(1:5)) == 'sofar') then + if (is_local%wrap%comp_present(compatm)) defaultMasks(compatm,1) = 1 + endif if ( trim(coupling_mode) /= 'cesm') then if (is_local%wrap%comp_present(compatm) .and. trim(atm_name(1:4)) == 'datm') then defaultMasks(compatm,1) = 0 diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 3d888bcfa..7630f26a7 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -423,6 +423,11 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, srcMaskValue = ispval_mask end if end if + if (coupling_mode(1:5) == 'sofar') then + if (n1 == compatm .and. n2 == compwav) then + srcMaskValue = ispval_mask + end if + end if write(string,'(a,i10,a,i10)') trim(compname(n1))//' to '//trim(compname(n2))//' srcMask = ', & srcMaskValue,' dstMask = ',dstMaskValue call ESMF_LogWrite(trim(string), ESMF_LOGMSG_INFO) From c0fedacc8c81281d52bbf8f4723c1d30a5c064ca Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Tue, 11 Mar 2025 05:05:02 +0000 Subject: [PATCH 33/47] Force all masks to 1 (mask land) --- mediator/med_internalstate_mod.F90 | 1 + mediator/med_map_mod.F90 | 8 +++++++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90 index d0288f87d..460a7c8ab 100644 --- a/mediator/med_internalstate_mod.F90 +++ b/mediator/med_internalstate_mod.F90 @@ -673,6 +673,7 @@ subroutine med_internalstate_defaultmasks(gcomp, rc) endif if ( trim(coupling_mode(1:5)) == 'sofar') then if (is_local%wrap%comp_present(compatm)) defaultMasks(compatm,1) = 1 + if (is_local%wrap%comp_present(compwav)) defaultMasks(compwav,1) = 1 endif if ( trim(coupling_mode) /= 'cesm') then if (is_local%wrap%comp_present(compatm) .and. trim(atm_name(1:4)) == 'datm') then diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 7630f26a7..45c9d51a5 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -423,9 +423,15 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, srcMaskValue = ispval_mask end if end if + ! For sofar atm-wav, override all masks to 1 if (coupling_mode(1:5) == 'sofar') then if (n1 == compatm .and. n2 == compwav) then - srcMaskValue = ispval_mask + srcMaskValue = 1 + dstMaskValue = 1 + end if + if (n1 == compwav .and. n2 == compatm) then + srcMaskValue = 1 + dstMaskValue = 1 end if end if write(string,'(a,i10,a,i10)') trim(compname(n1))//' to '//trim(compname(n2))//' srcMask = ', & From 8912af555a7046608491099040bc1c341fcb61e0 Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Wed, 12 Mar 2025 00:03:22 +0000 Subject: [PATCH 34/47] Add src and dst Mask to runtime parameters --- mediator/med.F90 | 48 ++++++++++++++++++++++++++++++ mediator/med_internalstate_mod.F90 | 15 ++++++---- mediator/med_map_mod.F90 | 10 +++---- 3 files changed, 63 insertions(+), 10 deletions(-) diff --git a/mediator/med.F90 b/mediator/med.F90 index 5e45ca9e7..8b965f340 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -44,6 +44,7 @@ module MED use med_internalstate_mod , only : ncomps, compname use med_internalstate_mod , only : compmed, compatm, compocn, compice, complnd, comprof, compwav, compglc use med_internalstate_mod , only : coupling_mode, aoflux_code, aoflux_ccpp_suite + use med_internalstate_mod , only : srcMaskAtm, dstMaskAtm, srcMaskWav, dstMaskWav use esmFlds , only : med_fldList_GetocnalbfldList, med_fldList_type use esmFlds , only : med_fldList_GetNumFlds, med_fldList_GetFldNames, med_fldList_GetFldInfo use esmFlds , only : med_fldList_Document_Mapping, med_fldList_Document_Merging @@ -825,6 +826,53 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) write(logunit,*) end if + write(msgString,'(A,i6)') trim(subname)//': Mediator dbug_flag is ',dbug_flag + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + + ! Get srcMask and dstMask for wave and atmosphere + if (coupling_mode(1:5) == 'sofar') then + ! srcMaskAtm + call NUOPC_CompAttributeGet(gcomp, name='srcMaskAtm', value=srcMaskAtm, isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (.not. isPresent .and. .not. isSet) then + call ESMF_LogWrite("srcMaskAtm is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) + else + write(msgString,'(i6)') ': srcMaskAtm = ',srcMaskAtm + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + end if + + ! dstMaskAtm + call NUOPC_CompAttributeGet(gcomp, name='dstMaskAtm', value=dstMaskAtm, isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (.not. isPresent .and. .not. isSet) then + call ESMF_LogWrite("dstMaskAtm is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) + else + write(msgString,'(i6)') ': dstMaskAtm = ',dstMaskAtm + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + end if + + ! srcMaskWav + call NUOPC_CompAttributeGet(gcomp, name='srcMaskWav', value=srcMaskWav, isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (.not. isPresent .and. .not. isSet) then + call ESMF_LogWrite("srcMaskWav is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) + else + write(msgString,'(i6)') ': srcMaskWav = ',srcMaskWav + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + end if + + ! dstMaskWav + call NUOPC_CompAttributeGet(gcomp, name='dstMaskWav', value=dstMaskWav, isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (.not. isPresent .and. .not. isSet) then + call ESMF_LogWrite("dstMaskWav is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) + else + write(msgString,'(i6)') ': dstMaskWav = ',dstMaskWav + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + end if + + end if + ! Initialize memory for fldlistTo and fldlistFr - this is need for the calls below for the ! advertise phase call med_fldlist_init1(ncomps) diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90 index 460a7c8ab..cc15d5213 100644 --- a/mediator/med_internalstate_mod.F90 +++ b/mediator/med_internalstate_mod.F90 @@ -56,7 +56,11 @@ module med_internalstate_mod character(len=CL), public :: aoflux_ccpp_suite ! Default src and destination masks for mapping - integer, public, allocatable :: defaultMasks(:,:) + integer, public, allocatable :: defaultMasks(:,:) ! defaultMasks are set to ispval_mask (defined in med_constants_mod.F90) + integer, public :: srcMaskAtm ! 0=sea, 1=land, 2=ice ! srcMaskValue for atmosphere + integer, public :: dstMaskAtm ! 0=sea, 1=land, 2=ice ! dstMaskValue for atmosphere + integer, public :: srcMaskWav ! 0=sea, 1=land ! srcMaskValue for wave + integer, public :: dstMaskWav ! 0=sea, 1=land ! dstMaskValue for waves ! Mapping integer , public, parameter :: mapunset = 0 @@ -671,10 +675,11 @@ subroutine med_internalstate_defaultmasks(gcomp, rc) if ( trim(coupling_mode) == 'hafs') then if (is_local%wrap%comp_present(compatm)) defaultMasks(compatm,1) = 1 endif - if ( trim(coupling_mode(1:5)) == 'sofar') then - if (is_local%wrap%comp_present(compatm)) defaultMasks(compatm,1) = 1 - if (is_local%wrap%comp_present(compwav)) defaultMasks(compwav,1) = 1 - endif +! comment this out, so that default masks are set to ispval if missing from esm_run.config +! if ( trim(coupling_mode(1:5)) == 'sofar') then +! if (is_local%wrap%comp_present(compatm)) defaultMasks(compatm,1) = 1 +! if (is_local%wrap%comp_present(compwav)) defaultMasks(compwav,1) = 1 +! endif if ( trim(coupling_mode) /= 'cesm') then if (is_local%wrap%comp_present(compatm) .and. trim(atm_name(1:4)) == 'datm') then defaultMasks(compatm,1) = 0 diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 45c9d51a5..42afe7c30 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -350,7 +350,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, use med_internalstate_mod , only : mapfillv_bilnr, mapbilnr_nstod, mapconsf_aofrac use med_internalstate_mod , only : compocn, compwav, complnd, compname, compatm use med_internalstate_mod , only : coupling_mode, dststatus_print - use med_internalstate_mod , only : defaultMasks + use med_internalstate_mod , only : defaultMasks, srcMaskAtm, dstMaskAtm, srcMaskWav, dstMaskWav use med_constants_mod , only : ispval_mask => med_constants_ispval_mask ! input/output variables @@ -426,12 +426,12 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, ! For sofar atm-wav, override all masks to 1 if (coupling_mode(1:5) == 'sofar') then if (n1 == compatm .and. n2 == compwav) then - srcMaskValue = 1 - dstMaskValue = 1 + srcMaskValue = srcMaskAtm + dstMaskValue = dstMaskAtm end if if (n1 == compwav .and. n2 == compatm) then - srcMaskValue = 1 - dstMaskValue = 1 + srcMaskValue = srcMaskWav + dstMaskValue = dstMaskWav end if end if write(string,'(a,i10,a,i10)') trim(compname(n1))//' to '//trim(compname(n2))//' srcMask = ', & From ba16b4d4df1c76ba8d826c859d42075038882fa9 Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Wed, 12 Mar 2025 00:50:42 +0000 Subject: [PATCH 35/47] Bugfix, remove leftover example --- mediator/med.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/mediator/med.F90 b/mediator/med.F90 index 8b965f340..f691c7c93 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -826,9 +826,6 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) write(logunit,*) end if - write(msgString,'(A,i6)') trim(subname)//': Mediator dbug_flag is ',dbug_flag - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) - ! Get srcMask and dstMask for wave and atmosphere if (coupling_mode(1:5) == 'sofar') then ! srcMaskAtm From 1b470574df17c1cfc385f805fe5f925fcdefee8d Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Wed, 12 Mar 2025 05:47:46 +0000 Subject: [PATCH 36/47] declare msgString --- mediator/med.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/mediator/med.F90 b/mediator/med.F90 index f691c7c93..78bf1512f 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -693,6 +693,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) character(len=CS) :: transferOffer character(len=CS) :: cvalue character(len=8) :: cnum + character(len=CX) :: msgString type(InternalState) :: is_local type(med_fldlist_type), pointer :: fldListFr, fldListTo type(med_fldList_entry_type), pointer :: fld From bc85f7cfb381da60b2eac07ac31844688b6ef21d Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Wed, 12 Mar 2025 17:09:19 +0000 Subject: [PATCH 37/47] Fix message string type on write --- mediator/med.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/mediator/med.F90 b/mediator/med.F90 index 78bf1512f..759bfe590 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -835,7 +835,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) if (.not. isPresent .and. .not. isSet) then call ESMF_LogWrite("srcMaskAtm is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) else - write(msgString,'(i6)') ': srcMaskAtm = ',srcMaskAtm + write(msgString,'(A,i6)') ': srcMaskAtm = ',srcMaskAtm call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) end if @@ -845,7 +845,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) if (.not. isPresent .and. .not. isSet) then call ESMF_LogWrite("dstMaskAtm is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) else - write(msgString,'(i6)') ': dstMaskAtm = ',dstMaskAtm + write(msgString,'(A,i6)') ': dstMaskAtm = ',dstMaskAtm call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) end if @@ -855,7 +855,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) if (.not. isPresent .and. .not. isSet) then call ESMF_LogWrite("srcMaskWav is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) else - write(msgString,'(i6)') ': srcMaskWav = ',srcMaskWav + write(msgString,'(A,i6)') ': srcMaskWav = ',srcMaskWav call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) end if @@ -865,7 +865,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) if (.not. isPresent .and. .not. isSet) then call ESMF_LogWrite("dstMaskWav is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) else - write(msgString,'(i6)') ': dstMaskWav = ',dstMaskWav + write(msgString,'(A,i6)') ': dstMaskWav = ',dstMaskWav call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) end if From 8c92c76d1449281589c3d5bfbe4a7009152326fa Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Wed, 12 Mar 2025 18:56:18 +0000 Subject: [PATCH 38/47] Fix typekind error for NUOPC call --- mediator/med.F90 | 91 +++++++++++++++++++++++++++++++++++------------- 1 file changed, 66 insertions(+), 25 deletions(-) diff --git a/mediator/med.F90 b/mediator/med.F90 index 759bfe590..61aefe412 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -654,6 +654,42 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(msgString,'(A,i6)') trim(subname)//': Mediator dbug_flag is ',dbug_flag call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) +! ! Obtain srcMaskAtm setting if present; otherwise use default value in med_constants +! call NUOPC_CompAttributeGet(gcomp, name='srcMaskAtm', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) +! if (ChkErr(rc,__LINE__,u_FILE_u)) return +! if (isPresent .and. isSet) then +! read(cvalue,*) srcMaskAtm +! end if +! write(msgString,'(A,i6)') trim(subname)//': srcMaskAtm is ',srcMaskAtm +! call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) +! +! ! Obtain dstMaskAtm setting if present; otherwise use default value in med_constants +! call NUOPC_CompAttributeGet(gcomp, name='dstMaskAtm', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) +! if (ChkErr(rc,__LINE__,u_FILE_u)) return +! if (isPresent .and. isSet) then +! read(cvalue,*) dstMaskAtm +! end if +! write(msgString,'(A,i6)') trim(subname)//': dstMaskAtm is ',dstMaskAtm +! call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) +! +! ! Obtain srcMaskWav setting if present; otherwise use default value in med_constants +! call NUOPC_CompAttributeGet(gcomp, name='srcMaskWav', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) +! if (ChkErr(rc,__LINE__,u_FILE_u)) return +! if (isPresent .and. isSet) then +! read(cvalue,*) srcMaskWav +! end if +! write(msgString,'(A,i6)') trim(subname)//': srcMaskWav is ',srcMaskWav +! call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) +! +! ! Obtain dstMaskWav setting if present; otherwise use default value in med_constants +! call NUOPC_CompAttributeGet(gcomp, name='dstMaskWav', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) +! if (ChkErr(rc,__LINE__,u_FILE_u)) return +! if (isPresent .and. isSet) then +! read(cvalue,*) dstMaskWav +! end if +! write(msgString,'(A,i6)') trim(subname)//': dstMaskWav is ',dstMaskWav +! call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + ! Switch to IPDv03 by filtering all other phaseMap entries call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, acceptStringList=(/"IPDv03p"/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -828,45 +864,50 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) end if ! Get srcMask and dstMask for wave and atmosphere - if (coupling_mode(1:5) == 'sofar') then + if (trim(coupling_mode) == 'sofar.aw') then + ! srcMaskAtm - call NUOPC_CompAttributeGet(gcomp, name='srcMaskAtm', value=srcMaskAtm, isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='srcMaskAtm', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (.not. isPresent .and. .not. isSet) then - call ESMF_LogWrite("srcMaskAtm is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) - else - write(msgString,'(A,i6)') ': srcMaskAtm = ',srcMaskAtm - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + if (isPresent .and. isSet) then + call ESMF_LogWrite('srcMaskAtm = '// trim(cvalue), ESMF_LOGMSG_INFO) + read(trim(cvalue), '(i10)') srcMaskAtm + if (maintask) then + write(logunit,'(a)')trim(subname)//' srcMaskAtm is set to '//trim(cvalue) + end if end if ! dstMaskAtm - call NUOPC_CompAttributeGet(gcomp, name='dstMaskAtm', value=dstMaskAtm, isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='dstMaskAtm', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (.not. isPresent .and. .not. isSet) then - call ESMF_LogWrite("dstMaskAtm is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) - else - write(msgString,'(A,i6)') ': dstMaskAtm = ',dstMaskAtm - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + if (isPresent .and. isSet) then + call ESMF_LogWrite('dstMaskAtm = '// trim(cvalue), ESMF_LOGMSG_INFO) + read(trim(cvalue), '(i10)') dstMaskAtm + if (maintask) then + write(logunit,'(a)')trim(subname)//' dstMaskAtm is set to '//trim(cvalue) + end if end if ! srcMaskWav - call NUOPC_CompAttributeGet(gcomp, name='srcMaskWav', value=srcMaskWav, isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='srcMaskWav', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (.not. isPresent .and. .not. isSet) then - call ESMF_LogWrite("srcMaskWav is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) - else - write(msgString,'(A,i6)') ': srcMaskWav = ',srcMaskWav - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + if (isPresent .and. isSet) then + call ESMF_LogWrite('srcMaskWav = '// trim(cvalue), ESMF_LOGMSG_INFO) + read(trim(cvalue), '(i10)') srcMaskWav + if (maintask) then + write(logunit,'(a,i10)')trim(subname)//' srcMaskWav is set to ',srcMaskWav + end if end if ! dstMaskWav - call NUOPC_CompAttributeGet(gcomp, name='dstMaskWav', value=dstMaskWav, isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='dstMaskWav', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (.not. isPresent .and. .not. isSet) then - call ESMF_LogWrite("dstMaskWav is not present, and will be set to the default ispval_mask value", ESMF_LOGMSG_INFO) - else - write(msgString,'(A,i6)') ': dstMaskWav = ',dstMaskWav - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + if (isPresent .and. isSet) then + call ESMF_LogWrite('dstMaskWav = '// trim(cvalue), ESMF_LOGMSG_INFO) + read(trim(cvalue), '(i10)') dstMaskWav + if (maintask) then + write(logunit,'(a)')trim(subname)//' dstMaskWav is set to '//trim(cvalue) + end if end if end if From d02927aa259fd7e76273a16953a1cfc526eaa791 Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Wed, 12 Mar 2025 21:20:55 +0000 Subject: [PATCH 39/47] Remove trim from cvalue on read --- mediator/med.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/mediator/med.F90 b/mediator/med.F90 index 61aefe412..81300ac6b 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -871,7 +871,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then call ESMF_LogWrite('srcMaskAtm = '// trim(cvalue), ESMF_LOGMSG_INFO) - read(trim(cvalue), '(i10)') srcMaskAtm + read(cvalue, '(i10)') srcMaskAtm if (maintask) then write(logunit,'(a)')trim(subname)//' srcMaskAtm is set to '//trim(cvalue) end if @@ -882,7 +882,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then call ESMF_LogWrite('dstMaskAtm = '// trim(cvalue), ESMF_LOGMSG_INFO) - read(trim(cvalue), '(i10)') dstMaskAtm + read(cvalue, '(i10)') dstMaskAtm if (maintask) then write(logunit,'(a)')trim(subname)//' dstMaskAtm is set to '//trim(cvalue) end if @@ -893,7 +893,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then call ESMF_LogWrite('srcMaskWav = '// trim(cvalue), ESMF_LOGMSG_INFO) - read(trim(cvalue), '(i10)') srcMaskWav + read(cvalue, '(i10)') srcMaskWav if (maintask) then write(logunit,'(a,i10)')trim(subname)//' srcMaskWav is set to ',srcMaskWav end if @@ -904,7 +904,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then call ESMF_LogWrite('dstMaskWav = '// trim(cvalue), ESMF_LOGMSG_INFO) - read(trim(cvalue), '(i10)') dstMaskWav + read(cvalue, '(i10)') dstMaskWav if (maintask) then write(logunit,'(a)')trim(subname)//' dstMaskWav is set to '//trim(cvalue) end if From c4a9d59d48487711792e85514b74a197a52ee053 Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Wed, 12 Mar 2025 22:20:40 +0000 Subject: [PATCH 40/47] Cleanup, src/dst Mask work at runtime --- mediator/med.F90 | 38 +------------------------------------- 1 file changed, 1 insertion(+), 37 deletions(-) diff --git a/mediator/med.F90 b/mediator/med.F90 index 81300ac6b..eb91fc3a8 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -654,42 +654,6 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(msgString,'(A,i6)') trim(subname)//': Mediator dbug_flag is ',dbug_flag call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) -! ! Obtain srcMaskAtm setting if present; otherwise use default value in med_constants -! call NUOPC_CompAttributeGet(gcomp, name='srcMaskAtm', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) -! if (ChkErr(rc,__LINE__,u_FILE_u)) return -! if (isPresent .and. isSet) then -! read(cvalue,*) srcMaskAtm -! end if -! write(msgString,'(A,i6)') trim(subname)//': srcMaskAtm is ',srcMaskAtm -! call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) -! -! ! Obtain dstMaskAtm setting if present; otherwise use default value in med_constants -! call NUOPC_CompAttributeGet(gcomp, name='dstMaskAtm', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) -! if (ChkErr(rc,__LINE__,u_FILE_u)) return -! if (isPresent .and. isSet) then -! read(cvalue,*) dstMaskAtm -! end if -! write(msgString,'(A,i6)') trim(subname)//': dstMaskAtm is ',dstMaskAtm -! call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) -! -! ! Obtain srcMaskWav setting if present; otherwise use default value in med_constants -! call NUOPC_CompAttributeGet(gcomp, name='srcMaskWav', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) -! if (ChkErr(rc,__LINE__,u_FILE_u)) return -! if (isPresent .and. isSet) then -! read(cvalue,*) srcMaskWav -! end if -! write(msgString,'(A,i6)') trim(subname)//': srcMaskWav is ',srcMaskWav -! call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) -! -! ! Obtain dstMaskWav setting if present; otherwise use default value in med_constants -! call NUOPC_CompAttributeGet(gcomp, name='dstMaskWav', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) -! if (ChkErr(rc,__LINE__,u_FILE_u)) return -! if (isPresent .and. isSet) then -! read(cvalue,*) dstMaskWav -! end if -! write(msgString,'(A,i6)') trim(subname)//': dstMaskWav is ',dstMaskWav -! call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) - ! Switch to IPDv03 by filtering all other phaseMap entries call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, acceptStringList=(/"IPDv03p"/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -895,7 +859,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) call ESMF_LogWrite('srcMaskWav = '// trim(cvalue), ESMF_LOGMSG_INFO) read(cvalue, '(i10)') srcMaskWav if (maintask) then - write(logunit,'(a,i10)')trim(subname)//' srcMaskWav is set to ',srcMaskWav + write(logunit,'(a)')trim(subname)//' srcMaskWav is set to '//trim(cvalue) end if end if From 14b87c8025f18f0f2279ca7d0b84df6d309bba73 Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Tue, 18 Mar 2025 06:30:35 +0000 Subject: [PATCH 41/47] Point shr_log_error => shr_log_errMsg --- mediator/esmFlds.F90 | 2 +- mediator/med.F90 | 2 +- mediator/med_diag_mod.F90 | 2 +- mediator/med_io_mod.F90 | 2 +- mediator/med_map_mod.F90 | 2 +- mediator/med_merge_mod.F90 | 2 +- mediator/med_methods_mod.F90 | 2 +- mediator/med_phases_aofluxes_mod.F90 | 2 +- mediator/med_phases_history_mod.F90 | 2 +- mediator/med_phases_ocnalb_mod.F90 | 3 ++- mediator/med_phases_post_glc_mod.F90 | 2 +- mediator/med_phases_post_rof_mod.F90 | 2 +- mediator/med_phases_prep_glc_mod.F90 | 2 +- mediator/med_phases_prep_rof_mod.F90 | 2 +- mediator/med_phases_restart_mod.F90 | 2 +- 15 files changed, 16 insertions(+), 15 deletions(-) diff --git a/mediator/esmFlds.F90 b/mediator/esmFlds.F90 index 7a2959f4c..13b5872cc 100644 --- a/mediator/esmFlds.F90 +++ b/mediator/esmFlds.F90 @@ -4,7 +4,7 @@ module esmflds use med_internalstate_mod, only : compname, compocn, compatm, compice, comprof use med_internalstate_mod, only : mapfcopy, mapnames, mapunset use med_utils_mod , only : chkerr => med_utils_ChkErr - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med.F90 b/mediator/med.F90 index e654a35a2..c699ddfe3 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -53,7 +53,7 @@ module MED use esmFldsExchange_hafs_mod , only : esmFldsExchange_hafs use esmFldsExchange_sofar_mod, only : esmFldsExchange_sofar use med_phases_profile_mod , only : med_phases_profile_finalize - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_diag_mod.F90 b/mediator/med_diag_mod.F90 index df0d4e351..d8132339d 100644 --- a/mediator/med_diag_mod.F90 +++ b/mediator/med_diag_mod.F90 @@ -32,7 +32,7 @@ module med_diag_mod use med_methods_mod , only : fldbun_fldChk => med_methods_FB_FldChk use med_utils_mod , only : chkerr => med_utils_ChkErr use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_io_mod.F90 b/mediator/med_io_mod.F90 index c86f87c72..10789db08 100644 --- a/mediator/med_io_mod.F90 +++ b/mediator/med_io_mod.F90 @@ -19,7 +19,7 @@ module med_io_mod use med_methods_mod , only : FB_getFldPtr => med_methods_FB_getFldPtr use med_methods_mod , only : FB_getNameN => med_methods_FB_getNameN use med_utils_mod , only : chkerr => med_utils_ChkErr - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 29756b76d..8f9657f3b 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -9,7 +9,7 @@ module med_map_mod use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_utils_mod , only : chkerr => med_utils_ChkErr use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_merge_mod.F90 b/mediator/med_merge_mod.F90 index 6d12fa929..1106f58a3 100644 --- a/mediator/med_merge_mod.F90 +++ b/mediator/med_merge_mod.F90 @@ -16,7 +16,7 @@ module med_merge_mod use esmFlds , only : med_fldList_entry_type use esmFlds , only : med_fldList_findName use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90 index 734527cc1..fa2be097e 100644 --- a/mediator/med_methods_mod.F90 +++ b/mediator/med_methods_mod.F90 @@ -15,7 +15,7 @@ module med_methods_mod use med_constants_mod , only : czero => med_constants_czero use med_constants_mod , only : spval_init => med_constants_spval_init use med_utils_mod , only : ChkErr => med_utils_ChkErr - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90 index b3618c1ba..92e57e953 100644 --- a/mediator/med_phases_aofluxes_mod.F90 +++ b/mediator/med_phases_aofluxes_mod.F90 @@ -39,7 +39,7 @@ module med_phases_aofluxes_mod use shr_const_mod , only : rearth => SHR_CONST_REARTH use shr_const_mod , only : pi => SHR_CONST_PI #endif - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index b3899c285..a950c9de6 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -23,7 +23,7 @@ module med_phases_history_mod use med_io_mod , only : med_io_write, med_io_wopen, med_io_enddef, med_io_close use perf_mod , only : t_startf, t_stopf use pio , only : file_desc_t - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_phases_ocnalb_mod.F90 b/mediator/med_phases_ocnalb_mod.F90 index 0a09c76aa..d7b435327 100644 --- a/mediator/med_phases_ocnalb_mod.F90 +++ b/mediator/med_phases_ocnalb_mod.F90 @@ -10,7 +10,8 @@ module med_phases_ocnalb_mod use perf_mod , only : t_startf, t_stopf use shr_orb_mod , only : shr_orb_cosz, shr_orb_decl use shr_orb_mod , only : shr_orb_params, SHR_ORB_UNDEF_INT, SHR_ORB_UNDEF_REAL - use shr_log_mod , only : shr_log_unit, shr_log_error + use shr_log_mod , only : shr_log_unit + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_phases_post_glc_mod.F90 b/mediator/med_phases_post_glc_mod.F90 index 311324229..65046a7a1 100644 --- a/mediator/med_phases_post_glc_mod.F90 +++ b/mediator/med_phases_post_glc_mod.F90 @@ -30,7 +30,7 @@ module med_phases_post_glc_mod use med_map_mod , only : med_map_field_packed, med_map_field_normalized, med_map_field use glc_elevclass_mod , only : glc_mean_elevation_virtual, glc_get_fractional_icecov use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_phases_post_rof_mod.F90 b/mediator/med_phases_post_rof_mod.F90 index f21bf2271..4afde4bab 100644 --- a/mediator/med_phases_post_rof_mod.F90 +++ b/mediator/med_phases_post_rof_mod.F90 @@ -22,7 +22,7 @@ module med_phases_post_rof_mod use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d use med_methods_mod , only : fldbun_getmesh => med_methods_FB_getmesh use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_phases_prep_glc_mod.F90 b/mediator/med_phases_prep_glc_mod.F90 index e0e29089a..4668a4bda 100644 --- a/mediator/med_phases_prep_glc_mod.F90 +++ b/mediator/med_phases_prep_glc_mod.F90 @@ -44,7 +44,7 @@ module med_phases_prep_glc_mod use glc_elevclass_mod , only : glc_get_elevation_classes use glc_elevclass_mod , only : glc_get_fractional_icecov use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_phases_prep_rof_mod.F90 b/mediator/med_phases_prep_rof_mod.F90 index 1f6eeb0ba..f59f803e8 100644 --- a/mediator/med_phases_prep_rof_mod.F90 +++ b/mediator/med_phases_prep_rof_mod.F90 @@ -26,7 +26,7 @@ module med_phases_prep_rof_mod use med_methods_mod , only : fldbun_fldchk => med_methods_FB_fldchk use med_methods_mod , only : FB_check_for_nans => med_methods_FB_check_for_nans use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private diff --git a/mediator/med_phases_restart_mod.F90 b/mediator/med_phases_restart_mod.F90 index ebf3727d5..3504df3ae 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -14,7 +14,7 @@ module med_phases_restart_mod use med_phases_prep_glc_mod , only : FBocnAccum2glc_o, ocnAccum2glc_cnt use med_phases_prep_rof_mod , only : FBlndAccum2rof_l, lndAccum2rof_cnt use pio , only : file_desc_t - use shr_log_mod , only : shr_log_error + use shr_log_mod , only : shr_log_error => shr_log_errMsg implicit none private From 50866b75ff4db03a0841471b59650cea5abaccf9 Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Tue, 18 Mar 2025 20:05:18 +0000 Subject: [PATCH 42/47] Revert shr_log_error pointing/renaming --- mediator/esmFlds.F90 | 2 +- mediator/med.F90 | 2 +- mediator/med_diag_mod.F90 | 2 +- mediator/med_io_mod.F90 | 2 +- mediator/med_map_mod.F90 | 2 +- mediator/med_merge_mod.F90 | 2 +- mediator/med_methods_mod.F90 | 2 +- mediator/med_phases_aofluxes_mod.F90 | 2 +- mediator/med_phases_history_mod.F90 | 2 +- mediator/med_phases_ocnalb_mod.F90 | 3 +-- mediator/med_phases_post_glc_mod.F90 | 2 +- mediator/med_phases_post_rof_mod.F90 | 2 +- mediator/med_phases_prep_glc_mod.F90 | 2 +- mediator/med_phases_prep_rof_mod.F90 | 2 +- mediator/med_phases_restart_mod.F90 | 2 +- 15 files changed, 15 insertions(+), 16 deletions(-) diff --git a/mediator/esmFlds.F90 b/mediator/esmFlds.F90 index 13b5872cc..7a2959f4c 100644 --- a/mediator/esmFlds.F90 +++ b/mediator/esmFlds.F90 @@ -4,7 +4,7 @@ module esmflds use med_internalstate_mod, only : compname, compocn, compatm, compice, comprof use med_internalstate_mod, only : mapfcopy, mapnames, mapunset use med_utils_mod , only : chkerr => med_utils_ChkErr - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med.F90 b/mediator/med.F90 index c699ddfe3..e654a35a2 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -53,7 +53,7 @@ module MED use esmFldsExchange_hafs_mod , only : esmFldsExchange_hafs use esmFldsExchange_sofar_mod, only : esmFldsExchange_sofar use med_phases_profile_mod , only : med_phases_profile_finalize - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_diag_mod.F90 b/mediator/med_diag_mod.F90 index d8132339d..df0d4e351 100644 --- a/mediator/med_diag_mod.F90 +++ b/mediator/med_diag_mod.F90 @@ -32,7 +32,7 @@ module med_diag_mod use med_methods_mod , only : fldbun_fldChk => med_methods_FB_FldChk use med_utils_mod , only : chkerr => med_utils_ChkErr use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_io_mod.F90 b/mediator/med_io_mod.F90 index 10789db08..c86f87c72 100644 --- a/mediator/med_io_mod.F90 +++ b/mediator/med_io_mod.F90 @@ -19,7 +19,7 @@ module med_io_mod use med_methods_mod , only : FB_getFldPtr => med_methods_FB_getFldPtr use med_methods_mod , only : FB_getNameN => med_methods_FB_getNameN use med_utils_mod , only : chkerr => med_utils_ChkErr - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 8f9657f3b..29756b76d 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -9,7 +9,7 @@ module med_map_mod use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_utils_mod , only : chkerr => med_utils_ChkErr use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_merge_mod.F90 b/mediator/med_merge_mod.F90 index 1106f58a3..6d12fa929 100644 --- a/mediator/med_merge_mod.F90 +++ b/mediator/med_merge_mod.F90 @@ -16,7 +16,7 @@ module med_merge_mod use esmFlds , only : med_fldList_entry_type use esmFlds , only : med_fldList_findName use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90 index fa2be097e..734527cc1 100644 --- a/mediator/med_methods_mod.F90 +++ b/mediator/med_methods_mod.F90 @@ -15,7 +15,7 @@ module med_methods_mod use med_constants_mod , only : czero => med_constants_czero use med_constants_mod , only : spval_init => med_constants_spval_init use med_utils_mod , only : ChkErr => med_utils_ChkErr - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90 index 92e57e953..b3618c1ba 100644 --- a/mediator/med_phases_aofluxes_mod.F90 +++ b/mediator/med_phases_aofluxes_mod.F90 @@ -39,7 +39,7 @@ module med_phases_aofluxes_mod use shr_const_mod , only : rearth => SHR_CONST_REARTH use shr_const_mod , only : pi => SHR_CONST_PI #endif - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index a950c9de6..b3899c285 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -23,7 +23,7 @@ module med_phases_history_mod use med_io_mod , only : med_io_write, med_io_wopen, med_io_enddef, med_io_close use perf_mod , only : t_startf, t_stopf use pio , only : file_desc_t - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_phases_ocnalb_mod.F90 b/mediator/med_phases_ocnalb_mod.F90 index d7b435327..0a09c76aa 100644 --- a/mediator/med_phases_ocnalb_mod.F90 +++ b/mediator/med_phases_ocnalb_mod.F90 @@ -10,8 +10,7 @@ module med_phases_ocnalb_mod use perf_mod , only : t_startf, t_stopf use shr_orb_mod , only : shr_orb_cosz, shr_orb_decl use shr_orb_mod , only : shr_orb_params, SHR_ORB_UNDEF_INT, SHR_ORB_UNDEF_REAL - use shr_log_mod , only : shr_log_unit - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_unit, shr_log_error implicit none private diff --git a/mediator/med_phases_post_glc_mod.F90 b/mediator/med_phases_post_glc_mod.F90 index 65046a7a1..311324229 100644 --- a/mediator/med_phases_post_glc_mod.F90 +++ b/mediator/med_phases_post_glc_mod.F90 @@ -30,7 +30,7 @@ module med_phases_post_glc_mod use med_map_mod , only : med_map_field_packed, med_map_field_normalized, med_map_field use glc_elevclass_mod , only : glc_mean_elevation_virtual, glc_get_fractional_icecov use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_phases_post_rof_mod.F90 b/mediator/med_phases_post_rof_mod.F90 index 4afde4bab..f21bf2271 100644 --- a/mediator/med_phases_post_rof_mod.F90 +++ b/mediator/med_phases_post_rof_mod.F90 @@ -22,7 +22,7 @@ module med_phases_post_rof_mod use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d use med_methods_mod , only : fldbun_getmesh => med_methods_FB_getmesh use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_phases_prep_glc_mod.F90 b/mediator/med_phases_prep_glc_mod.F90 index 4668a4bda..e0e29089a 100644 --- a/mediator/med_phases_prep_glc_mod.F90 +++ b/mediator/med_phases_prep_glc_mod.F90 @@ -44,7 +44,7 @@ module med_phases_prep_glc_mod use glc_elevclass_mod , only : glc_get_elevation_classes use glc_elevclass_mod , only : glc_get_fractional_icecov use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_phases_prep_rof_mod.F90 b/mediator/med_phases_prep_rof_mod.F90 index f59f803e8..1f6eeb0ba 100644 --- a/mediator/med_phases_prep_rof_mod.F90 +++ b/mediator/med_phases_prep_rof_mod.F90 @@ -26,7 +26,7 @@ module med_phases_prep_rof_mod use med_methods_mod , only : fldbun_fldchk => med_methods_FB_fldchk use med_methods_mod , only : FB_check_for_nans => med_methods_FB_check_for_nans use perf_mod , only : t_startf, t_stopf - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private diff --git a/mediator/med_phases_restart_mod.F90 b/mediator/med_phases_restart_mod.F90 index 3504df3ae..ebf3727d5 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -14,7 +14,7 @@ module med_phases_restart_mod use med_phases_prep_glc_mod , only : FBocnAccum2glc_o, ocnAccum2glc_cnt use med_phases_prep_rof_mod , only : FBlndAccum2rof_l, lndAccum2rof_cnt use pio , only : file_desc_t - use shr_log_mod , only : shr_log_error => shr_log_errMsg + use shr_log_mod , only : shr_log_error implicit none private From d37ca6339824fe4dcc2905e317134c442580bc3e Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Tue, 18 Mar 2025 20:11:25 +0000 Subject: [PATCH 43/47] Add chanes to /shared dir manually --- shared/shr_abort_mod.F90 | 62 ++++++++++------------------------------ shared/shr_kind_mod.F90 | 2 ++ shared/shr_log_mod.F90 | 48 ++++++++++++++++++++++++++++++- 3 files changed, 64 insertions(+), 48 deletions(-) diff --git a/shared/shr_abort_mod.F90 b/shared/shr_abort_mod.F90 index 230cb61e2..ac61eaa4a 100644 --- a/shared/shr_abort_mod.F90 +++ b/shared/shr_abort_mod.F90 @@ -7,10 +7,7 @@ module shr_abort_mod ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from ! when these routines were defined in shr_sys_mod.) - use, intrinsic :: iso_fortran_env, only: output_unit, error_unit - use ESMF, only : ESMF_Finalize, ESMF_END_ABORT, ESMF_LOGMSG_ERROR, ESMF_LogWrite use shr_kind_mod, only : shr_kind_in, shr_kind_cx - use shr_log_mod , only : s_logunit => shr_log_Unit #ifdef CPRNAG ! NAG does not provide this as an intrinsic, but it does provide modules @@ -34,18 +31,21 @@ module shr_abort_mod contains !=============================================================================== - subroutine shr_abort_abort(string,rc) + subroutine shr_abort_abort(string,rc, line, file) + use esmf, only : ESMF_LOGWRITE, ESMF_LOGMSG_ERROR, ESMF_FINALIZE, ESMF_END_ABORT + use shr_log_mod, only : shr_log_error ! Consistent stopping mechanism !----- arguments ----- character(len=*) , intent(in), optional :: string ! error message string integer(shr_kind_in), intent(in), optional :: rc ! error code - - !----- local ----- - + integer(shr_kind_in), intent(in), optional :: line + character(len=*), intent(in), optional :: file + ! Local version of the string. ! (Gets a default value if string is not present.) character(len=shr_kind_cx) :: local_string + integer :: lrc !------------------------------------------------------------------------------- if (present(string)) then @@ -53,15 +53,17 @@ subroutine shr_abort_abort(string,rc) else local_string = "Unknown error submitted to shr_abort_abort." end if - - call print_error_to_logs("ERROR", local_string) - - call shr_abort_backtrace() - if(present(rc)) then write(local_string, *) trim(local_string), ' rc=',rc + lrc = rc + else + lrc = 0 endif - call ESMF_LogWrite(local_string, ESMF_LOGMSG_ERROR) + + call shr_log_error(local_string, rc=lrc, line=line, file=file) + + call shr_abort_backtrace() + call ESMF_Finalize(endflag=ESMF_END_ABORT) ! A compiler's abort method may print a backtrace or do other nice @@ -118,41 +120,7 @@ end subroutine xl_trbk #endif - flush(error_unit) - end subroutine shr_abort_backtrace !=============================================================================== - !=============================================================================== - subroutine print_error_to_logs(error_type, message) - ! This routine prints error messages to s_logunit (which is standard output - ! for most tasks in CESM) and also to standard error if s_logunit is a - ! file. - ! - ! It also flushes these output units. - - character(len=*), intent(in) :: error_type, message - - integer, allocatable :: log_units(:) - - integer :: i - - if (s_logunit == output_unit .or. s_logunit == error_unit) then - ! If the log unit number is standard output or standard error, just - ! print to that. - allocate(log_units(1), source=[s_logunit]) - else - ! Otherwise print the same message to both the log unit and standard - ! error. - allocate(log_units(2), source=[error_unit, s_logunit]) - end if - - do i = 1, size(log_units) - write(log_units(i),*) trim(error_type), ": ", trim(message) - flush(log_units(i)) - end do - - end subroutine print_error_to_logs - !=============================================================================== - end module shr_abort_mod diff --git a/shared/shr_kind_mod.F90 b/shared/shr_kind_mod.F90 index be988e541..9437f97a5 100644 --- a/shared/shr_kind_mod.F90 +++ b/shared/shr_kind_mod.F90 @@ -16,5 +16,7 @@ MODULE shr_kind_mod 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 + real(kind=shr_kind_r8),parameter :: tinyvalue = tiny(1._shr_kind_R8) ! tiny value + real(kind=shr_kind_r8),parameter :: hugevalue = huge(1._shr_kind_r8) ! huge value END MODULE shr_kind_mod diff --git a/shared/shr_log_mod.F90 b/shared/shr_log_mod.F90 index a7e4c70e3..306c00752 100644 --- a/shared/shr_log_mod.F90 +++ b/shared/shr_log_mod.F90 @@ -16,7 +16,7 @@ module shr_log_mod use shr_kind_mod, only: shr_kind_in, shr_kind_cx use shr_strconvert_mod, only: toString - use, intrinsic :: iso_fortran_env, only: output_unit + use, intrinsic :: iso_fortran_env, only: output_unit, error_unit implicit none private @@ -31,6 +31,7 @@ module shr_log_mod public :: shr_log_OOBMsg public :: shr_log_setLogUnit public :: shr_log_getLogUnit + public :: shr_log_error ! !PUBLIC DATA MEMBERS: @@ -117,4 +118,49 @@ subroutine shr_log_getLogUnit(unit) end subroutine shr_log_getLogUnit + subroutine shr_log_error(string, rc, line, file) + use esmf, only : ESMF_LOGWRITE, ESMF_LOGMSG_ERROR, ESMF_FINALIZE, ESMF_END_ABORT, ESMF_FAILURE, ESMF_SUCCESS + ! This routine prints error messages to shr_log_unit (which is standard output + ! for most tasks in CESM), to the ESMF PET files and to standard error if shr_log_unit is a + ! file. Sets rc to ESMF_FAILURE on return. + + !----- arguments ----- + character(len=*) , intent(in) :: string ! error message string + integer(shr_kind_in), intent(inout), optional :: rc ! error code + integer(shr_kind_in), intent(in), optional :: line + character(len=*), intent(in), optional :: file + + ! Local version of the string. + ! (Gets a default value if string is not present.) + character(len=shr_kind_cx) :: local_string + integer, allocatable :: log_units(:) + integer :: i + !------------------------------------------------------------------------------- + + local_string = trim(string) + if(present(rc)) then + if (rc /= ESMF_SUCCESS) then + write(local_string, *) trim(local_string), ' rc=',rc + endif + rc = ESMF_FAILURE + endif + + call ESMF_LogWrite(local_string, ESMF_LOGMSG_ERROR, line=line, file=file) + if (shr_log_unit == output_unit .or. shr_log_unit == error_unit) then + ! If the log unit number is standard output or standard error, just + ! print to that. + allocate(log_units(1), source=[shr_log_unit]) + else + ! Otherwise print the same message to both the log unit and standard + ! error. + allocate(log_units(2), source=[error_unit, shr_log_unit]) + end if + + do i = 1, size(log_units) + write(log_units(i),*) trim(local_string) + flush(log_units(i)) + end do + + end subroutine shr_log_error + end module shr_log_mod From 8d6a2b86dc4424f858c741b2899c7954ab2d594b Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Tue, 18 Mar 2025 20:16:51 +0000 Subject: [PATCH 44/47] Remove deprecated ESMF_Logwrite for shr_log_error --- mediator/med_methods_mod.F90 | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90 index 734527cc1..742052f2b 100644 --- a/mediator/med_methods_mod.F90 +++ b/mediator/med_methods_mod.F90 @@ -2319,12 +2319,8 @@ subroutine med_methods_State_GetScalar(state, scalar_id, scalar_value, flds_scal call ESMF_FieldGet(field, farrayPtr = farrayptr, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (scalar_id < 0 .or. scalar_id > flds_scalar_num) then - write (msgString,*) ": ERROR in scalar_id, must be between [0,flds_scalar_num]. However, scalar_id = ", scalar_id ! Sofar added - call ESMF_LogWrite(trim(subname)//trim(msgString), ESMF_LOGMSG_INFO, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return -! call shr_log_error(trim(subname)//": ERROR in scalar_id", line=__LINE__, file=u_FILE_u, rc=rc) -! return + call shr_log_error(trim(subname)//": ERROR in scalar_id", line=__LINE__, file=u_FILE_u, rc=rc) + return endif tmp(:) = farrayptr(scalar_id,:) endif From 6458b34e3b2a5c7e416ff82dc7b32efed4e1e9a6 Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Tue, 18 Mar 2025 20:24:30 +0000 Subject: [PATCH 45/47] Remove dststatus_print from med_map_mod.F90 --- mediator/med_map_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 29756b76d..6f0d2c2ef 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -363,7 +363,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, use med_internalstate_mod , only : mapnstod, mapnstod_consd, mapnstod_consf, mapnstod_consd use med_internalstate_mod , only : mapfillv_bilnr, mapbilnr_nstod, mapconsf_aofrac use med_internalstate_mod , only : compocn, compwav, complnd, compname, compatm - use med_internalstate_mod , only : coupling_mode, dststatus_print + use med_internalstate_mod , only : coupling_mode use med_internalstate_mod , only : defaultMasks, srcMaskAtm, dstMaskAtm, srcMaskWav, dstMaskWav use med_constants_mod , only : ispval_mask => med_constants_ispval_mask From 4ecd24acf2596752fd14bb16c1520e02d42e35fc Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Tue, 18 Mar 2025 20:49:43 +0000 Subject: [PATCH 46/47] Add nuopc_shr_methods from CESM_share/src/ --- shared/nuopc_shr_methods.F90 | 848 +++++++++++++++++++++++++++++++++++ 1 file changed, 848 insertions(+) create mode 100644 shared/nuopc_shr_methods.F90 diff --git a/shared/nuopc_shr_methods.F90 b/shared/nuopc_shr_methods.F90 new file mode 100644 index 000000000..ebc169c44 --- /dev/null +++ b/shared/nuopc_shr_methods.F90 @@ -0,0 +1,848 @@ +module nuopc_shr_methods + use ESMF , only : operator(<), operator(/=), operator(+) + use ESMF , only : operator(-), operator(*) , operator(>=) + use ESMF , only : operator(<=), operator(>), operator(==), MOD + use ESMF , only : ESMF_LOGERR_PASSTHRU, ESMF_LogFoundError, ESMF_MAXSTR + use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_FAILURE + use ESMF , only : ESMF_State, ESMF_StateGet + use ESMF , only : ESMF_Field, ESMF_FieldGet + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_GridCompSet + use ESMF , only : ESMF_GeomType_Flag, ESMF_FieldStatus_Flag + use ESMF , only : ESMF_Mesh, ESMF_MeshGet, ESMF_AlarmSet + use ESMF , only : ESMF_GEOMTYPE_MESH, ESMF_GEOMTYPE_GRID, ESMF_FIELDSTATUS_COMPLETE + use ESMF , only : ESMF_Clock, ESMF_ClockCreate, ESMF_ClockGet, ESMF_ClockSet + use ESMF , only : ESMF_ClockPrint, ESMF_ClockAdvance + use ESMF , only : ESMF_Alarm, ESMF_AlarmCreate, ESMF_AlarmGet, ESMF_AlarmSet + use ESMF , only : ESMF_Calendar, ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN + use ESMF , only : ESMF_Time, ESMF_TimeGet, ESMF_TimeSet, ESMF_ClockGetAlarm + use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalSet, ESMF_TimeIntervalGet + use ESMF , only : ESMF_VM, ESMF_VMGet, ESMF_VMBroadcast, ESMF_VMGetCurrent + use ESMF , only : ESMF_ClockGetNextTime + use NUOPC , only : NUOPC_CompAttributeGet + use NUOPC_Model , only : NUOPC_ModelGet + use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : shr_log_setLogUnit + + implicit none + private + + public :: memcheck + public :: get_component_instance + public :: set_component_logging + public :: log_clock_advance + public :: state_getscalar + public :: state_setscalar + public :: state_diagnose + public :: alarmInit + public :: get_minimum_timestep + public :: chkerr + public :: shr_get_rpointer_name + private :: timeInit + private :: field_getfldptr + + ! Module data + + ! Clock and alarm options shared with esm_time_mod along with dtime_driver which is initialized there. + ! Dtime_driver is needed here for setting alarm options which use the nstep option and is a module variable + ! to avoid requiring a change in all model caps. + character(len=*), public, parameter :: & + optNONE = "none" , & + optNever = "never" , & + optNSteps = "nstep" , & + optNSeconds = "nsecond" , & + optNMinutes = "nminute" , & + optNHours = "nhour" , & + optNDays = "nday" , & + optNMonths = "nmonth" , & + optNYears = "nyear" , & + optMonthly = "monthly" , & + optYearly = "yearly" , & + optDate = "date" , & + optEnd = "end" , & + optGLCCouplingPeriod = "glc_coupling_period" + + integer, public :: dtime_drv ! initialized in esm_time_mod.F90 + + integer, parameter :: SecPerDay = 86400 ! Seconds per day + integer, parameter :: memdebug_level=1 + character(len=1024) :: msgString + character(len=*), parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine memcheck(string, level, maintask) + + ! input/output variables + character(len=*) , intent(in) :: string + integer , intent(in) :: level + logical , intent(in) :: maintask + + ! local variables +#ifdef CESMCOUPLED + integer, external :: GPTLprint_memusage + integer :: ierr = 0 +#endif + !----------------------------------------------------------------------- + +#ifdef CESMCOUPLED + if ((maintask .and. memdebug_level > level) .or. memdebug_level > level+1) then + ierr = GPTLprint_memusage(string) + endif +#endif + + end subroutine memcheck + +!=============================================================================== + + subroutine get_component_instance(gcomp, inst_suffix, inst_index, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + character(len=*) , intent(out) :: inst_suffix + integer , intent(out) :: inst_index + integer , intent(out) :: rc + + ! local variables + logical :: isPresent + character(len=4) :: cvalue + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call NUOPC_CompAttributeGet(gcomp, name="inst_suffix", isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name="inst_suffix", value=inst_suffix, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + cvalue = inst_suffix(2:) + read(cvalue, *) inst_index + else + inst_suffix = "" + inst_index=1 + endif + + end subroutine get_component_instance + +!=============================================================================== + subroutine set_component_logging(gcomp, maintask, logunit, shrlogunit, rc) + use NUOPC, only: NUOPC_CompAttributeSet, NUOPC_CompAttributeAdd + ! input/output variables + type(ESMF_GridComp) :: gcomp + logical, intent(in) :: maintask + integer, intent(out) :: logunit + integer, intent(out) :: shrlogunit + integer, intent(out) :: rc + + ! local variables + character(len=CL) :: diro + character(len=CL) :: logfile + character(len=CL) :: inst_suffix + integer :: inst_index ! Not used here + integer :: n + character(len=CL) :: name + character(len=*), parameter :: subname = "("//__FILE__//": set_component_logging)" + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if (maintask) then + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call get_component_instance(gcomp, inst_suffix, inst_index, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Multiinstance logfile name needs a correction + if(len_trim(inst_suffix) > 0) then + n = index(logfile, '.') + logfile = logfile(1:n-1)//trim(inst_suffix)//logfile(n:) + endif + + open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) + + else + logUnit = 6 + endif + + call ESMF_GridCompGet(gcomp, name=name, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(trim(subname)//": setting logunit for component: "//trim(name), ESMF_LOGMSG_INFO) + call NUOPC_CompAttributeAdd(gcomp, (/"logunit"/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeSet(gcomp, "logunit", logunit, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call shr_log_setLogUnit (logunit) + ! Still need to set this return value + shrlogunit = logunit + call ESMF_LogWrite(trim(subname)//": done for component "//trim(name), ESMF_LOGMSG_INFO) + end subroutine set_component_logging + +!=============================================================================== + + subroutine log_clock_advance(clock, component, logunit, rc) + + ! input/output variables + type(ESMF_Clock) :: clock + character(len=*) , intent(in) :: component + integer , intent(in) :: logunit + integer , intent(out) :: rc + + ! local variables + character(len=CL) :: cvalue, prestring + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + write(prestring, *) "------>Advancing ",trim(component)," from: " + call ESMF_ClockPrint(clock, options="currTime", unit=cvalue, preString=trim(prestring), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + write(logunit, *) trim(cvalue) + + call ESMF_ClockPrint(clock, options="stopTime", unit=cvalue, & + preString="--------------------------------> to: ", rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + write(logunit, *) trim(cvalue) + + end subroutine log_clock_advance + +!=============================================================================== + + subroutine state_getscalar(state, scalar_id, scalar_value, flds_scalar_name, flds_scalar_num, rc) + + ! ---------------------------------------------- + ! Get scalar data from State for a particular name and broadcast it to all other pets + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_State), intent(in) :: state + integer, intent(in) :: scalar_id + real(r8), intent(out) :: scalar_value + character(len=*), intent(in) :: flds_scalar_name + integer, intent(in) :: flds_scalar_num + integer, intent(inout) :: rc + + ! local variables + integer :: mytask + type(ESMF_VM) :: vm + type(ESMF_Field) :: field + real(r8), pointer :: farrayptr(:,:) + real(r8) :: tmp(1) + character(len=*), parameter :: subname='(state_getscalar)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_VMGetCurrent(vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localPet=mytask, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_StateGet(State, itemName=trim(flds_scalar_name), field=field, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (mytask == 0) then + call ESMF_FieldGet(field, farrayPtr = farrayptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (scalar_id < 0 .or. scalar_id > flds_scalar_num) then + call ESMF_LogWrite(trim(subname)//": ERROR in scalar_id", ESMF_LOGMSG_INFO, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + endif + tmp(:) = farrayptr(scalar_id,:) + endif + call ESMF_VMBroadCast(vm, tmp, 1, 0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + scalar_value = tmp(1) + + end subroutine state_getscalar + +!================================================================================ + + subroutine state_setscalar(scalar_value, scalar_id, State, flds_scalar_name, flds_scalar_num, rc) + + ! ---------------------------------------------- + ! Set scalar data from State for a particular name + ! ---------------------------------------------- + + ! input/output arguments + real(r8), intent(in) :: scalar_value + integer, intent(in) :: scalar_id + type(ESMF_State), intent(inout) :: State + character(len=*), intent(in) :: flds_scalar_name + integer, intent(in) :: flds_scalar_num + integer, intent(inout) :: rc + + ! local variables + integer :: mytask + type(ESMF_Field) :: lfield + type(ESMF_VM) :: vm + real(r8), pointer :: farrayptr(:,:) + character(len=*), parameter :: subname='(state_setscalar)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_VMGetCurrent(vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localPet=mytask, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_StateGet(State, itemName=trim(flds_scalar_name), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (mytask == 0) then + call ESMF_FieldGet(lfield, farrayPtr = farrayptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (scalar_id < 0 .or. scalar_id > flds_scalar_num) then + call ESMF_LogWrite(trim(subname)//": ERROR in scalar_id", ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + endif + farrayptr(scalar_id,1) = scalar_value + endif + + end subroutine state_setscalar + +!=============================================================================== + + subroutine state_diagnose(State, string, rc) + + ! ---------------------------------------------- + ! Diagnose status of State + ! ---------------------------------------------- + + type(ESMF_State), intent(in) :: state + character(len=*), intent(in) :: string + integer , intent(out) :: rc + + ! local variables + integer :: n + type(ESMf_Field) :: lfield + integer :: fieldCount, lrank + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) + real(r8), pointer :: dataPtr1d(:) + real(r8), pointer :: dataPtr2d(:,:) + character(len=*),parameter :: subname='(state_diagnose)' + ! ---------------------------------------------- + + call ESMF_StateGet(state, itemCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldnamelist(fieldCount)) + + call ESMF_StateGet(state, itemNameList=lfieldnamelist, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do n = 1, fieldCount + + call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (lrank == 0) then + ! no local data + elseif (lrank == 1) then + if (size(dataPtr1d) > 0) then + write(msgString,'(A,a)') trim(string)//': for 1d field '//trim(lfieldnamelist(n)) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + write(msgString,'(A,3g14.7,i8)') trim(string)//': 1d field '//trim(lfieldnamelist(n)), & + minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + endif + elseif (lrank == 2) then + if (size(dataPtr2d) > 0) then + write(msgString,'(A,a)') trim(string)//': for 2d field '//trim(lfieldnamelist(n)) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + write(msgString,'(A,3g14.7,i8)') trim(string)//': 2d field '//trim(lfieldnamelist(n)), & + minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + endif + else + call shr_sys_abort(trim(subname)//": ERROR rank not supported ") + endif + enddo + + deallocate(lfieldnamelist) + + end subroutine state_diagnose + +!=============================================================================== + + subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) + + ! ---------------------------------------------- + ! for a field, determine rank and return fldptr1 or fldptr2 + ! abort is true by default and will abort if fldptr is not yet allocated in field + ! rank returns 0, 1, or 2. 0 means fldptr not allocated and abort=false + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_Field) , intent(in) :: field + real(r8), pointer , intent(inout), optional :: fldptr1(:) + real(r8), pointer , intent(inout), optional :: fldptr2(:,:) + integer , intent(out) , optional :: rank + logical , intent(in) , optional :: abort + integer , intent(out) , optional :: rc + + ! local variables + type(ESMF_GeomType_Flag) :: geomtype + type(ESMF_FieldStatus_Flag) :: status + type(ESMF_Mesh) :: lmesh + integer :: lrank, nnodes, nelements + logical :: labort + character(len=*), parameter :: subname='(field_getfldptr)' + ! ---------------------------------------------- + + if (.not.present(rc)) then + call shr_sys_abort(trim(subname)//": ERROR rc not present ", & + line=__LINE__, file=u_FILE_u) + endif + + rc = ESMF_SUCCESS + + labort = .true. + if (present(abort)) then + labort = abort + endif + lrank = -99 + + call ESMF_FieldGet(field, status=status, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (status /= ESMF_FIELDSTATUS_COMPLETE) then + lrank = 0 + if (labort) then + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + else + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + endif + else + + call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (geomtype == ESMF_GEOMTYPE_MESH) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field, mesh=lmesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (nnodes == 0 .and. nelements == 0) lrank = 0 + else + call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + endif ! geomtype + + if (lrank == 0) then + call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & + ESMF_LOGMSG_INFO) + elseif (lrank == 1) then + if (.not.present(fldptr1)) then + call shr_sys_abort(trim(subname)//": ERROR missing rank=1 array ", & + line=__LINE__, file=u_FILE_u) + endif + call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (lrank == 2) then + if (.not.present(fldptr2)) then + call shr_sys_abort(trim(subname)//": ERROR missing rank=2 array ", & + line=__LINE__, file=u_FILE_u) + endif + call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(trim(subname)//": ERROR in rank ", & + line=__LINE__, file=u_FILE_u) + endif + + endif ! status + + if (present(rank)) then + rank = lrank + endif + + end subroutine field_getfldptr + +!=============================================================================== + + subroutine alarmInit( clock, alarm, option, & + opt_n, opt_ymd, opt_tod, RefTime, alarmname, advance_clock, rc) + use ESMF, only : ESMF_AlarmPrint, ESMF_ClockGetAlarm + ! Setup an alarm in a clock + ! Notes: The ringtime sent to AlarmCreate MUST be the next alarm + ! time. If you send an arbitrary but proper ringtime from the + ! past and the ring interval, the alarm will always go off on the + ! next clock advance and this will cause serious problems. Even + ! if it makes sense to initialize an alarm with some reference + ! time and the alarm interval, that reference time has to be + ! advance forward to be >= the current time. In the logic below + ! we set an appropriate "NextAlarm" and then we make sure to + ! advance it properly based on the ring interval. + + ! input/output variables + type(ESMF_Clock) , intent(inout) :: clock ! clock + type(ESMF_Alarm) , intent(inout) :: alarm ! alarm + character(len=*) , intent(in) :: option ! alarm option + integer , optional , intent(in) :: opt_n ! alarm freq + integer , optional , intent(in) :: opt_ymd ! alarm ymd + integer , optional , intent(in) :: opt_tod ! alarm tod (sec) + type(ESMF_Time) , optional , intent(in) :: RefTime ! ref time + character(len=*) , optional , intent(in) :: alarmname ! alarm name + logical , optional , intent(in) :: advance_clock ! advance clock to trigger alarm + integer , intent(inout) :: rc ! Return code + + ! local variables + type(ESMF_Calendar) :: cal ! calendar + integer :: lymd ! local ymd + integer :: ltod ! local tod + integer :: cyy,cmm,cdd,csec ! time info + character(len=64) :: lalarmname ! local alarm name + logical :: update_nextalarm ! update next alarm + type(ESMF_Time) :: CurrTime ! Current Time + type(ESMF_Time) :: NextAlarm ! Next restart alarm time + type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval + type(ESMF_TimeInterval) :: TimeStepInterval ! Component timestep interval + character(len=*), parameter :: subname = '(alarmInit): ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + lalarmname = 'alarm_unknown' + if (present(alarmname)) lalarmname = trim(alarmname) + ltod = 0 + if (present(opt_tod)) ltod = opt_tod + lymd = -1 + if (present(opt_ymd)) lymd = opt_ymd + + call ESMF_ClockGet(clock, CurrTime=CurrTime, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet(CurrTime, yy=cyy, mm=cmm, dd=cdd, s=csec, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! initial guess of next alarm, this will be updated below + if (present(RefTime)) then + NextAlarm = RefTime + else + NextAlarm = CurrTime + endif + + ! Determine calendar + call ESMF_ClockGet(clock, calendar=cal) + + ! Error checks + if (trim(option) == optdate) then + if (.not. present(opt_ymd)) then + call shr_sys_abort(trim(subname)//trim(option)//' requires opt_ymd') + end if + if (lymd < 0 .or. ltod < 0) then + call shr_sys_abort(subname//trim(option)//'opt_ymd, opt_tod invalid') + end if + else if (& + trim(option) == optNSteps .or. trim(option) == trim(optNSteps)//'s' .or. & + trim(option) == optNSeconds .or. trim(option) == trim(optNSeconds)//'s' .or. & + trim(option) == optNMinutes .or. trim(option) == trim(optNMinutes)//'s' .or. & + trim(option) == optNHours .or. trim(option) == trim(optNHours)//'s' .or. & + trim(option) == optNDays .or. trim(option) == trim(optNDays)//'s' .or. & + trim(option) == optNMonths .or. trim(option) == trim(optNMonths)//'s' .or. & + trim(option) == optNYears .or. trim(option) == trim(optNYears)//'s' ) then + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + end if + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Determine inputs for call to create alarm + selectcase (trim(option)) + + case (optNONE) + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optNever) + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optDate) + call timeInit(NextAlarm, lymd, cal, ltod, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optNSteps,trim(optNSteps)//'s') + call ESMF_ClockGet(clock, TimeStep=TimestepInterval, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if(dtime_drv > 0) then + call ESMF_TimeIntervalSet(AlarmInterval, s=dtime_drv, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + AlarmInterval = AlarmInterval * opt_n + ! timestepinterval*0 is 0 of kind ESMF_TimeStepInterval + if (mod(AlarmInterval, TimestepInterval) /= (TimestepInterval*0)) then + call shr_sys_abort(subname//'illegal Alarm setting for '//trim(alarmname)) + endif + update_nextalarm = .true. + + case (optNSeconds,trim(optNSeconds)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMinutes,trim(optNMinutes)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNHours,trim(optNHours)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNDays,trim(optNDays)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMonths,trim(optNMonths)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optMonthly) + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. + + case (optNYears, trim(optNYears)//'s') + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optYearly) + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. + + case (optEnd) + call ESMF_ClockGetAlarm(clock, alarmname="alarm_stop", alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_AlarmGet(alarm, ringTime=NextAlarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + case default + call shr_sys_abort(subname//'unknown option '//trim(option)) + + end select + + ! -------------------------------------------------------------------------------- + ! --- AlarmInterval and NextAlarm should be set --- + ! -------------------------------------------------------------------------------- + + ! --- advance Next Alarm so it won't ring on first timestep for + ! --- most options above. go back one alarminterval just to be careful + + if (update_nextalarm) then + NextAlarm = NextAlarm - AlarmInterval + do while (NextAlarm <= CurrTime) + NextAlarm = NextAlarm + AlarmInterval + enddo + endif + alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, & + ringInterval=AlarmInterval, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Advance model clock to trigger alarm then reset model clock back to currtime + if (present(advance_clock)) then + if (advance_clock) then + call ESMF_AlarmSet(alarm, clock=clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet(clock, currTime=CurrTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockAdvance(clock,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockSet(clock, currTime=currtime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if + + end subroutine alarmInit + +!=============================================================================== + + subroutine timeInit( Time, ymd, cal, tod, rc) + + ! Create the ESMF_Time object corresponding to the given input time, + ! given in YMD (Year Month Day) and TOD (Time-of-day) format. + ! Set the time by an integer as YYYYMMDD and integer seconds in the day + + ! input/output parameters: + type(ESMF_Time) , intent(inout) :: Time ! ESMF time + integer , intent(in) :: ymd ! year, month, day YYYYMMDD + type(ESMF_Calendar) , intent(in) :: cal ! ESMF calendar + integer , intent(in) :: tod ! time of day in seconds + integer , intent(out) :: rc + + ! local variables + integer :: year, mon, day ! year, month, day as integers + integer :: tdate ! temporary date + character(len=*), parameter :: subname='(timeInit)' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if ( (ymd < 0) .or. (tod < 0) .or. (tod > SecPerDay) )then + call shr_sys_abort( subname//'ERROR yymmdd is a negative number or time-of-day out of bounds' ) + end if + + tdate = abs(ymd) + year = int(tdate/10000) + if (ymd < 0) year = -year + mon = int( mod(tdate,10000)/ 100) + day = mod(tdate, 100) + + call ESMF_TimeSet( Time, yy=year, mm=mon, dd=day, s=tod, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine timeInit + +!=============================================================================== + + integer function get_minimum_timestep(gcomp, rc) + ! Get the minimum timestep interval in seconds based on the nuopc.config variables *_cpl_dt, + ! if none of these variables are defined this routine will throw an error + type(ESMF_GridComp), intent(in) :: gcomp + integer, intent(out) :: rc + + character(len=CS) :: cvalue + integer :: comp_dt ! coupling interval of component + integer, parameter :: ncomps = 8 + character(len=3),dimension(ncomps) :: compname + character(len=10) :: comp + logical :: is_present, is_set ! determine if these variables are used + integer :: i + !--------------------------------------------------------------------------- + ! Determine driver clock timestep + !--------------------------------------------------------------------------- + compname = (/"atm", "lnd", "ice", "ocn", "rof", "glc", "wav", "esp"/) + get_minimum_timestep = huge(1) + + do i=1,ncomps + comp = compname(i)//"_cpl_dt" + + call NUOPC_CompAttributeGet(gcomp, name=comp, isPresent=is_present, isSet=is_set, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (is_present .and. is_set) then + call NUOPC_CompAttributeGet(gcomp, name=comp, value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) comp_dt + get_minimum_timestep = min(comp_dt, get_minimum_timestep) + endif + enddo + + if(get_minimum_timestep == huge(1)) then + call shr_sys_abort('minimum_timestep_error: this option is not supported ') + endif + if(get_minimum_timestep <= 0) then + call shr_sys_abort('minimum_timestep_error ERROR ') + endif + end function get_minimum_timestep + + subroutine shr_get_rpointer_name(gcomp, compname, ymd, time, rpfile, mode, rc) + type(ESMF_GRIDCOMP), intent(in) :: gcomp + character(len=3), intent(in) :: compname + integer, intent(in) :: ymd + integer, intent(in) :: time + character(len=*), intent(out) :: rpfile + character(len=*), intent(in) :: mode + integer, intent(out) :: rc + + ! local vars + integer :: yr, mon, day + character(len=16) timestr + logical :: isPresent + character(len=ESMF_MAXSTR) :: inst_suffix + character(len=*), parameter :: subname='shr_get_rpointer_name' + + rc = ESMF_SUCCESS + + inst_suffix = "" + call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', isPresent=isPresent, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if(ispresent) call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', value=inst_suffix, rc=rc) + + yr = ymd/10000 + mon = (ymd - yr*10000)/100 + day = (ymd - yr*10000 - mon*100) + write(timestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',time + write(rpfile,*) "rpointer."//compname//trim(inst_suffix)//'.'//trim(timestr) + rpfile = adjustl(rpfile) + if (mode.eq.'read') then + inquire(file=trim(rpfile), exist=isPresent) + if(.not. isPresent) then + rpfile = "rpointer."//compname//trim(inst_suffix) + inquire(file=trim(rpfile), exist=isPresent) + if(.not. isPresent) then + call shr_sys_abort( subname//'ERROR no rpointer file found in '//rpfile//' or in '//rpfile//'.'//timestr ) + endif + endif + endif + end subroutine shr_get_rpointer_name + + logical function chkerr(rc, line, file) + + integer, intent(in) :: rc + integer, intent(in) :: line + character(len=*), intent(in) :: file + + integer :: lrc + + chkerr = .false. + lrc = rc + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then + chkerr = .true. + endif + end function chkerr + +end module nuopc_shr_methods From 314fd5bd7de497f695b87f918fa5a0b986287771 Mon Sep 17 00:00:00 2001 From: Miguel Solano Date: Wed, 19 Mar 2025 00:14:08 +0000 Subject: [PATCH 47/47] Add nuopc_shr_methods.F90 to /shared/CMakeLists --- shared/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/shared/CMakeLists.txt b/shared/CMakeLists.txt index 79949528b..aae4504e4 100644 --- a/shared/CMakeLists.txt +++ b/shared/CMakeLists.txt @@ -1,7 +1,7 @@ project(shared Fortran) include(ExternalProject) -add_library(shared shr_infnan_mod.F90 shr_kind_mod.F90 shr_orb_mod.F90 shr_sys_mod.F90 shr_sys_mod.F90 shr_sys_mod.F90 shr_sys_mod.F90 shr_log_mod.F90 shr_strconvert_mod.F90 shr_abort_mod.F90 shr_const_mod.F90) +add_library(shared shr_infnan_mod.F90 shr_kind_mod.F90 shr_orb_mod.F90 shr_sys_mod.F90 shr_sys_mod.F90 shr_sys_mod.F90 shr_sys_mod.F90 shr_log_mod.F90 shr_strconvert_mod.F90 shr_abort_mod.F90 shr_const_mod.F90 nuopc_shr_methods.F90) target_include_directories (shared PUBLIC ${CMAKE_CURRENT_SOURCE_DIR} ${ESMF_F90COMPILEPATHS} ${PIO_Fortran_INCLUDE_DIRS})