diff --git a/CMakeLists.txt b/CMakeLists.txt
index 524307c7dc..31710aa7a7 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -100,6 +100,8 @@ list(APPEND fms_fortran_src_files
column_diagnostics/column_diagnostics.F90
constants/constants.F90
constants/fmsconstants.F90
+ constants4/constants4.F90
+ constants4/fmsconstants4.F90
coupler/atmos_ocean_fluxes.F90
coupler/coupler_types.F90
coupler/ensemble_manager.F90
diff --git a/constants4/constants4.F90 b/constants4/constants4.F90
new file mode 100644
index 0000000000..c244b6a428
--- /dev/null
+++ b/constants4/constants4.F90
@@ -0,0 +1,176 @@
+!***********************************************************************
+!* GNU Lesser General Public License
+!*
+!* This file is part of the GFDL Flexible Modeling System (FMS).
+!*
+!* FMS is free software: you can redistribute it and/or modify it under
+!* the terms of the GNU Lesser General Public License as published by
+!* the Free Software Foundation, either version 3 of the License, or (at
+!* your option) any later version.
+!*
+!* FMS is distributed in the hope that it will be useful, but WITHOUT
+!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+!* for more details.
+!*
+!* You should have received a copy of the GNU Lesser General Public
+!* License along with FMS. If not, see .
+!***********************************************************************
+!> @defgroup constants_mod constants_mod
+!> @ingroup constants
+!> @brief Defines useful constants for Earth. Constants are defined as real
+!! parameters. Constants are accessed through the "use" statement.
+!> @author Bin Li
+!!
+!> Constants have been declared as type REAL, PARAMETER.
+!!
+!! The value a constant can not be changed in a users program.
+!! New constants can be defined in terms of values from the
+!! constants module using a parameter statement.
+!!
+!! The name given to a particular constant may be changed.
+!!
+!! Constants can be used on the right side on an assignment statement
+!! (their value can not be reassigned).
+!!
+!! Example:
+!!
+!! @verbatim
+!! use constants_mod, only: TFREEZE, grav_new => GRAV
+!! real, parameter :: grav_inv = 1.0 / grav_new
+!! tempc(:,:,:) = tempk(:,:,:) - TFREEZE
+!! geopotential(:,:) = height(:,:) * grav_new
+!! @endverbatim
+
+!> @file
+!> @brief File for @ref constants_mod
+
+!> @addtogroup constants_mod
+!> @{
+module constantsR4_mod
+
+!---variable for strong typing grid parameters
+use platform_mod, only: r8_kind, r4_kind
+implicit none
+private
+
+! Include variable "version" to be written to log file.
+#include
+!-----------------------------------------------------------------------
+! version is public so that write_version_number can be called for constants_mod
+! by fms_init
+public :: version
+
+real(r4_kind) :: realnumber !< dummy variable to use in HUGE initializations
+
+!! The small_fac parameter is used to alter the radius of the earth to allow one to
+!! examine non-hydrostatic effects without the need to run full-earth high-resolution
+!! simulations (<13km) that will tax hardware resources.
+#ifdef SMALL_EARTH
+#if defined(DCMIP) || (defined(HIWPP) && defined(SUPER_K))
+ real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 120._r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90
+#elif defined(HIWPP)
+ real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 166.7_r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90
+#else
+ real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 10._r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90
+#endif
+#else
+ real(r4_kind), public, parameter :: small_fac = 1._r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90
+#endif
+
+#ifdef GFS_PHYS
+! SJL: the following are from fv3_gfsphysics/gfs_physics/physics/physcons.f90
+real(r4_kind), public, parameter :: RADIUS = 6.3712e+6_r8_kind * small_fac !< Radius of the Earth [m]
+real(kind=r8_kind), public, parameter :: PI_8 = 3.1415926535897931_r8_kind !< Ratio of circle circumference to diameter [N/A]
+real(r4_kind), public, parameter :: PI = 3.1415926535897931_r8_kind !< Ratio of circle circumference to diameter [N/A]
+real(r4_kind), public, parameter :: OMEGA = 7.2921e-5_r8_kind / small_fac !< Rotation rate of the Earth [1/s]
+real(r4_kind), public, parameter :: GRAV = 9.80665_r8_kind !< Acceleration due to gravity [m/s^2]
+real(kind=r8_kind), public, parameter :: GRAV_8 = 9.80665_r8_kind !< Acceleration due to gravity [m/s^2] (REAL(KIND=8))
+real(r4_kind), public, parameter :: RDGAS = 287.05_r8_kind !< Gas constant for dry air [J/kg/deg]
+real(r4_kind), public, parameter :: RVGAS = 461.50_r8_kind !< Gas constant for water vapor [J/kg/deg]
+! Extra:
+real(r4_kind), public, parameter :: HLV = 2.5e6_r8_kind !< Latent heat of evaporation [J/kg]
+real(r4_kind), public, parameter :: HLF = 3.3358e5_r8_kind !< Latent heat of fusion [J/kg]
+real(r4_kind), public, parameter :: con_cliq = 4.1855e+3_r8_kind !< spec heat H2O liq [J/kg/K]
+real(r4_kind), public, parameter :: con_csol = 2.1060e+3_r8_kind !< spec heat H2O ice [J/kg/K]
+real(r4_kind), public, parameter :: CP_AIR = 1004.6_r8_kind !< Specific heat capacity of dry air at constant pressure [J/kg/deg]
+real(r4_kind), public, parameter :: KAPPA = RDGAS/CP_AIR !< RDGAS / CP_AIR [dimensionless]
+real(r4_kind), public, parameter :: TFREEZE = 273.15_r8_kind !< Freezing temperature of fresh water [K]
+
+#else
+
+real(r4_kind), public, parameter :: RADIUS = 6371.0e+3_r8_kind * small_fac !< Radius of the Earth [m]
+real(kind=8), public, parameter :: PI_8 = 3.14159265358979323846_r8_kind !< Ratio of circle circumference to diameter [N/A]
+real(r4_kind), public, parameter :: PI = 3.14159265358979323846_r8_kind !< Ratio of circle circumference to diameter [N/A]
+real(r4_kind), public, parameter :: OMEGA = 7.292e-5_r8_kind / small_fac !< Rotation rate of the Earth [1/s]
+real(r4_kind), public, parameter :: GRAV = 9.80_r8_kind !< Acceleration due to gravity [m/s^2]
+real(r4_kind), public, parameter :: RDGAS = 287.04_r8_kind !< Gas constant for dry air [J/kg/deg]
+real(r4_kind), public, parameter :: RVGAS = 461.50_r8_kind !< Gas constant for water vapor [J/kg/deg]
+! Extra:
+real(r4_kind), public, parameter :: HLV = 2.500e6_r8_kind !< Latent heat of evaporation [J/kg]
+real(r4_kind), public, parameter :: HLF = 3.34e5_r8_kind !< Latent heat of fusion [J/kg]
+real(r4_kind), public, parameter :: KAPPA = 2.0_r8_kind/7.0_r8_kind !< RDGAS / CP_AIR [dimensionless]
+real(r4_kind), public, parameter :: CP_AIR = RDGAS/KAPPA !< Specific heat capacity of dry air at constant pressure [J/kg/deg]
+real(r4_kind), public, parameter :: TFREEZE = 273.16_r8_kind !< Freezing temperature of fresh water [K]
+#endif
+
+real(r4_kind), public, parameter :: STEFAN = 5.6734e-8_r8_kind !< Stefan-Boltzmann constant [W/m^2/deg^4]
+
+real(r4_kind), public, parameter :: CP_VAPOR = 4.0_r8_kind*RVGAS !< Specific heat capacity of water vapor at constant pressure [J/kg/deg]
+real(r4_kind), public, parameter :: CP_OCEAN = 3989.24495292815_r8_kind !< Specific heat capacity taken from McDougall (2002)
+ !! "Potential Enthalpy ..." [J/kg/deg]
+real(r4_kind), public, parameter :: RHO0 = 1.035e3_r8_kind !< Average density of sea water [kg/m^3]
+real(r4_kind), public, parameter :: RHO0R = 1.0_r8_kind/RHO0 !< Reciprocal of average density of sea water [m^3/kg]
+real(r4_kind), public, parameter :: RHO_CP = RHO0*CP_OCEAN !< (kg/m^3)*(cal/kg/deg C)(joules/cal) = (joules/m^3/deg C) [J/m^3/deg]
+
+real(r4_kind), public, parameter :: ES0 = 1.0_r8_kind !< Humidity factor. Controls the humidity content of the atmosphere through
+ !! the Saturation Vapour Pressure expression when using DO_SIMPLE. [dimensionless]
+real(r4_kind), public, parameter :: DENS_H2O = 1000._r8_kind !< Density of liquid water [kg/m^3]
+real(r4_kind), public, parameter :: HLS = HLV + HLF !< Latent heat of sublimation [J/kg]
+
+real(r4_kind), public, parameter :: WTMAIR = 2.896440E+01_r8_kind !< Molecular weight of air [AMU]
+real(r4_kind), public, parameter :: WTMH2O = WTMAIR*(RDGAS/RVGAS) !< Molecular weight of water [AMU]
+real(r4_kind), public, parameter :: WTMOZONE = 47.99820_r8_kind !< Molecular weight of ozone [AMU]
+real(r4_kind), public, parameter :: WTMC = 12.00000_r8_kind !< Molecular weight of carbon [AMU]
+real(r4_kind), public, parameter :: WTMCO2 = 44.00995_r8_kind !< Molecular weight of carbon dioxide [AMU]
+real(r4_kind), public, parameter :: WTMCH4 = 16.0425_r8_kind !< Molecular weight of methane [AMU]
+real(r4_kind), public, parameter :: WTMO2 = 31.9988_r8_kind !< Molecular weight of molecular oxygen [AMU]
+real(r4_kind), public, parameter :: WTMCFC11 = 137.3681_r8_kind !< Molecular weight of CFC-11 (CCl3F) [AMU]
+real(r4_kind), public, parameter :: WTMCFC12 = 120.9135_r8_kind !< Molecular weight of CFC-21 (CCl2F2) [AMU]
+real(r4_kind), public, parameter :: WTMN = 14.0067_r8_kind !< Molecular weight of Nitrogen [AMU]
+real(r4_kind), public, parameter :: DIFFAC = 1.660000E+00_r8_kind !< Diffusivity factor [dimensionless]
+real(r4_kind), public, parameter :: AVOGNO = 6.023000E+23_r8_kind !< Avogadro's number [atoms/mole]
+real(r4_kind), public, parameter :: PSTD = 1.013250E+06_r8_kind !< Mean sea level pressure [dynes/cm^2]
+real(r4_kind), public, parameter :: PSTD_MKS = 101325.0_r8_kind !< Mean sea level pressure [N/m^2]
+
+real(r4_kind), public, parameter :: SECONDS_PER_DAY = 8.640000E+04_r8_kind !< Seconds in a day [s]
+real(r4_kind), public, parameter :: SECONDS_PER_HOUR = 3600._r8_kind !< Seconds in an hour [s]
+real(r4_kind), public, parameter :: SECONDS_PER_MINUTE = 60._r8_kind !< Seconds in a minute [s]
+real(r4_kind), public, parameter :: RAD_TO_DEG = 180._r8_kind/PI !< Degrees per radian [deg/rad]
+real(r4_kind), public, parameter :: DEG_TO_RAD = PI/180._r8_kind !< Radians per degree [rad/deg]
+real(r4_kind), public, parameter :: RADIAN = RAD_TO_DEG !< Equal to RAD_TO_DEG for backward compatability. [rad/deg]
+real(r4_kind), public, parameter :: ALOGMIN = -50.0_r8_kind !< Minimum value allowed as argument to log function [N/A]
+real(r4_kind), public, parameter :: EPSLN = 1.0e-40_r8_kind !< A small number to prevent divide by zero exceptions [N/A]
+
+real(r4_kind), public, parameter :: RADCON = ((1.0E+02*GRAV)/(1.0E+04*CP_AIR))*SECONDS_PER_DAY !< Factor used to convert flux divergence to
+ !! heating rate in degrees per day [deg sec/(cm day)]
+real(r4_kind), public, parameter :: RADCON_MKS = (GRAV/CP_AIR)*SECONDS_PER_DAY !< Factor used to convert flux divergence to
+ !! heating rate in degrees per day [deg sec/(m day)]
+real(r4_kind), public, parameter :: O2MIXRAT = 2.0953E-01_r8_kind !< Mixing ratio of molecular oxygen in air [dimensionless]
+real(r4_kind), public, parameter :: RHOAIR = 1.292269_r8_kind !< Reference atmospheric density [kg/m^3]
+real(r4_kind), public, parameter :: VONKARM = 0.40_r8_kind !< Von Karman constant [dimensionless]
+real(r4_kind), public, parameter :: C2DBARS = 1.e-4_r8_kind !< Converts rho*g*z (in mks) to dbars: 1dbar = 10^4 (kg/m^3)(m/s^2)m [dbars]
+real(r4_kind), public, parameter :: KELVIN = 273.15_r8_kind !< Degrees Kelvin at zero Celsius [K]
+
+public :: constants_init
+
+contains
+
+!> @brief dummy routine.
+subroutine constants_init
+
+end subroutine constants_init
+
+end module constantsR4_mod
+!> @}
+! close documentation grouping
diff --git a/constants4/fmsconstants4.F90 b/constants4/fmsconstants4.F90
new file mode 100644
index 0000000000..5d7af83dbc
--- /dev/null
+++ b/constants4/fmsconstants4.F90
@@ -0,0 +1,32 @@
+!***********************************************************************
+!* GNU Lesser General Public License
+!*
+!* This file is part of the GFDL Flexible Modeling System (FMS).
+!*
+!* FMS is free software: you can redistribute it and/or modify it under
+!* the terms of the GNU Lesser General Public License as published by
+!* the Free Software Foundation, either version 3 of the License, or (at
+!* your option) any later version.
+!*
+!* FMS is distributed in the hope that it will be useful, but WITHOUT
+!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+!* for more details.
+!*
+!* You should have received a copy of the GNU Lesser General Public
+!* License along with FMS. If not, see .
+!***********************************************************************
+!> @defgroup fmsconstants FMSconstants
+!> @ingroup libfms
+!> @brief Essentially a copy of @ref constants_mod for external usage alongside
+!! @ref libfms.
+!!
+!> See @ref constants_mod for individual parameter information.
+module FMSconstantsR4
+
+ !> rename to not conflict with any other version vars
+ use constantsR4_mod, version_constants => version
+
+ implicit none
+
+end module FMSconstantsR4
diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90
index 15d8f62801..ced3544ed0 100644
--- a/diag_manager/diag_axis.F90
+++ b/diag_manager/diag_axis.F90
@@ -113,7 +113,7 @@ MODULE diag_axis_mod
INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, direction,&
& set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position )
CHARACTER(len=*), INTENT(in) :: name !< Short name for axis
- REAL, DIMENSION(:), INTENT(in) :: DATA !< Array of coordinate values
+ CLASS(*), DIMENSION(:), INTENT(in) :: DATA !< Array of coordinate values
CHARACTER(len=*), INTENT(in) :: units !< Units for the axis
CHARACTER(len=*), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T")
CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis.
@@ -231,7 +231,15 @@ INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, directi
! Initialize Axes(diag_axis_init)
Axes(diag_axis_init)%name = TRIM(name)
- Axes(diag_axis_init)%data = DATA(1:axlen)
+ SELECT TYPE (DATA)
+ TYPE IS (real(kind=r4_kind))
+ Axes(diag_axis_init)%data = DATA(1:axlen)
+ TYPE IS (real(kind=r8_kind))
+ Axes(diag_axis_init)%data = real(DATA(1:axlen))
+ CLASS DEFAULT
+ CALL error_mesg('diag_axis_mod::diag_axis_init',&
+ & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
Axes(diag_axis_init)%units = units
Axes(diag_axis_init)%length = axlen
Axes(diag_axis_init)%set = set
@@ -460,7 +468,7 @@ SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,&
INTEGER, INTENT(out) :: direction !< Direction of data. (See @ref diag_axis_init for a description of
!! allowed values)
INTEGER, INTENT(out) :: edges !< Axis ID for the previously defined "edges axis".
- REAL, DIMENSION(:), INTENT(out) :: DATA !< Array of coordinate values for this axis.
+ CLASS(*), DIMENSION(:), INTENT(out) :: DATA !< Array of coordinate values for this axis.
INTEGER, INTENT(out), OPTIONAL :: num_attributes
TYPE(diag_atttype), ALLOCATABLE, DIMENSION(:), INTENT(out), OPTIONAL :: attributes
INTEGER, INTENT(out), OPTIONAL :: domain_position
@@ -481,7 +489,15 @@ SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,&
! array data is too small.
CALL error_mesg('diag_axis_mod::get_diag_axis', 'array data is too small', FATAL)
ELSE
- DATA(1:Axes(id)%length) = Axes(id)%data(1:Axes(id)%length)
+ SELECT TYPE (DATA)
+ TYPE IS (real(kind=r4_kind))
+ DATA(1:Axes(id)%length) = real(Axes(id)%data(1:Axes(id)%length), kind=r4_kind)
+ TYPE IS (real(kind=r8_kind))
+ DATA(1:Axes(id)%length) = Axes(id)%data(1:Axes(id)%length)
+ CLASS DEFAULT
+ CALL error_mesg('diag_axis_mod::get_diag_axis',&
+ & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
END IF
IF ( PRESENT(num_attributes) ) THEN
num_attributes = Axes(id)%num_attributes
diff --git a/diag_manager/diag_grid.F90 b/diag_manager/diag_grid.F90
index d394332cfe..12b9c9115f 100644
--- a/diag_manager/diag_grid.F90
+++ b/diag_manager/diag_grid.F90
@@ -132,10 +132,10 @@ MODULE diag_grid_mod
!! and before the first call to register the fields.
SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon)
TYPE(domain2d), INTENT(in) :: domain !< The domain to which the grid data corresponds.
- REAL, INTENT(in), DIMENSION(:,:) :: glo_lat !< The latitude information for the grid tile.
- REAL, INTENT(in), DIMENSION(:,:) :: glo_lon !< The longitude information for the grid tile.
- REAL, INTENT(in), DIMENSION(:,:) :: aglo_lat !< The latitude information for the a-grid tile.
- REAL, INTENT(in), DIMENSION(:,:) :: aglo_lon !< The longitude information for the a-grid tile.
+ CLASS(*), INTENT(in), DIMENSION(:,:) :: glo_lat !< The latitude information for the grid tile.
+ CLASS(*), INTENT(in), DIMENSION(:,:) :: glo_lon !< The longitude information for the grid tile.
+ CLASS(*), INTENT(in), DIMENSION(:,:) :: aglo_lat !< The latitude information for the a-grid tile.
+ CLASS(*), INTENT(in), DIMENSION(:,:) :: aglo_lon !< The longitude information for the a-grid tile.
INTEGER, DIMENSION(1) :: tile
INTEGER :: ntiles
@@ -254,14 +254,67 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon)
! If we are on tile 4 or 5, we need to transpose the grid to get
! this to work.
IF ( tile(1) == 4 .OR. tile(1) == 5 ) THEN
- diag_global_grid%aglo_lat = TRANSPOSE(aglo_lat)
- diag_global_grid%aglo_lon = TRANSPOSE(aglo_lon)
+ SELECT TYPE (aglo_lat)
+ TYPE IS (real(kind=r4_kind))
+ diag_global_grid%aglo_lat = TRANSPOSE(aglo_lat)
+ TYPE IS (real(kind=r8_kind))
+ diag_global_grid%aglo_lat = TRANSPOSE(real(aglo_lat))
+ CLASS DEFAULT
+ CALL error_mesg('diag_grid_mod::diag_grid_init',&
+ & 'The a-grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+
+ SELECT TYPE (aglo_lon)
+ TYPE IS (real(kind=r4_kind))
+ diag_global_grid%aglo_lon = TRANSPOSE(aglo_lon)
+ TYPE IS (real(kind=r8_kind))
+ diag_global_grid%aglo_lon = TRANSPOSE(real(aglo_lon))
+ CLASS DEFAULT
+ CALL error_mesg('diag_grid_mod::diag_grid_init',&
+ & 'The a-grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
ELSE
- diag_global_grid%aglo_lat = aglo_lat
- diag_global_grid%aglo_lon = aglo_lon
+ SELECT TYPE (aglo_lat)
+ TYPE IS (real(kind=r4_kind))
+ diag_global_grid%aglo_lat = aglo_lat
+ TYPE IS (real(kind=r8_kind))
+ diag_global_grid%aglo_lat = real(aglo_lat)
+ CLASS DEFAULT
+ CALL error_mesg('diag_grid_mod::diag_grid_init',&
+ & 'The a-grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+
+ SELECT TYPE (aglo_lon)
+ TYPE IS (real(kind=r4_kind))
+ diag_global_grid%aglo_lon = aglo_lon
+ TYPE IS (real(kind=r8_kind))
+ diag_global_grid%aglo_lon = real(aglo_lon)
+ CLASS DEFAULT
+ CALL error_mesg('diag_grid_mod::diag_grid_init',&
+ & 'The a-grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
END IF
- diag_global_grid%glo_lat = glo_lat
- diag_global_grid%glo_lon = glo_lon
+
+ SELECT TYPE (glo_lat)
+ TYPE IS (real(kind=r4_kind))
+ diag_global_grid%glo_lat = glo_lat
+ TYPE IS (real(kind=r8_kind))
+ diag_global_grid%glo_lat = real(glo_lat)
+ CLASS DEFAULT
+ CALL error_mesg('diag_grid_mod::diag_grid_init',&
+ & 'The grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+
+ SELECT TYPE (glo_lon)
+ TYPE IS (real(kind=r4_kind))
+ diag_global_grid%glo_lon = glo_lon
+ TYPE IS (real(kind=r8_kind))
+ diag_global_grid%glo_lon = real(glo_lon)
+ CLASS DEFAULT
+ CALL error_mesg('diag_grid_mod::diag_grid_init',&
+ & 'The grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+
diag_global_grid%dimI = i_dim
diag_global_grid%dimJ = j_dim
diag_global_grid%adimI = ai_dim
diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90
index 6cc20dbc48..42057fa443 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -329,12 +329,6 @@ MODULE diag_manager_mod
MODULE PROCEDURE send_data_1d
MODULE PROCEDURE send_data_2d
MODULE PROCEDURE send_data_3d
-#ifdef OVERLOAD_R8
- MODULE PROCEDURE send_data_0d_r8
- MODULE PROCEDURE send_data_1d_r8
- MODULE PROCEDURE send_data_2d_r8
- MODULE PROCEDURE send_data_3d_r8
-#endif
END INTERFACE
!> @brief Register a diagnostic field for a given module
@@ -374,8 +368,8 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
CHARACTER(len=*), INTENT(in) :: module_name, field_name
TYPE(time_type), OPTIONAL, INTENT(in) :: init_time
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name
- REAL, OPTIONAL, INTENT(in) :: missing_value
- REAL, DIMENSION(2), OPTIONAL, INTENT(in) :: RANGE
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value
+ CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged
CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg
INTEGER, OPTIONAL, INTENT(in) :: area, volume
@@ -383,6 +377,14 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time,
IF ( PRESENT(err_msg) ) err_msg = ''
+ ! Fatal error if range is present and its extent is not 2.
+ IF ( PRESENT(range) ) THEN
+ IF ( SIZE(range) .NE. 2 ) THEN
+ ! extent of range should be 2
+ CALL error_mesg ('diag_manager_mod::register_diag_field', 'extent of range should be 2', FATAL)
+ END IF
+ END IF
+
IF ( PRESENT(init_time) ) THEN
register_diag_field_scalar = register_diag_field_array(module_name, field_name,&
& (/null_axis_id/), init_time,long_name, units, missing_value, range, &
@@ -404,7 +406,8 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
INTEGER, INTENT(in) :: axes(:)
TYPE(time_type), INTENT(in) :: init_time
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name
- REAL, OPTIONAL, INTENT(in) :: missing_value, RANGE(2)
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value
+ CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range
LOGICAL, OPTIONAL, INTENT(in) :: mask_variant,verbose
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged
CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg
@@ -440,6 +443,14 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t
IF ( PRESENT(err_msg) ) err_msg = ''
+ ! Fatal error if range is present and its extent is not 2.
+ IF ( PRESENT(range) ) THEN
+ IF ( SIZE(range) .NE. 2 ) THEN
+ ! extent of range should be 2
+ CALL error_mesg ('diag_manager_mod::register_diag_field', 'extent of range should be 2', FATAL)
+ END IF
+ END IF
+
! Call register static, then set static back to false
register_diag_field_array = register_static_field(module_name, field_name, axes,&
& long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,&
@@ -589,8 +600,8 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
CHARACTER(len=*), INTENT(in) :: module_name, field_name
INTEGER, DIMENSION(:), INTENT(in) :: axes
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name
- REAL, OPTIONAL, INTENT(in) :: missing_value
- REAL, DIMENSION(2), OPTIONAL, INTENT(in) :: range
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value
+ CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range
LOGICAL, OPTIONAL, INTENT(in) :: mask_variant
LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC
LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged
@@ -603,7 +614,8 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated with this field
CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the modeling_realm attribute
- REAL :: missing_value_use
+ REAL :: missing_value_use !< Local copy of missing_value
+ REAL, DIMENSION(2) :: range_use !< Local copy of range
INTEGER :: field, num_axes, j, out_num, k
INTEGER, DIMENSION(3) :: siz, local_siz, local_start, local_end ! indices of local domain of global axes
INTEGER :: tile, file_num
@@ -622,7 +634,15 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
IF ( use_cmor ) THEN
missing_value_use = CMOR_MISSING_VALUE
ELSE
- missing_value_use = missing_value
+ SELECT TYPE (missing_value)
+ TYPE IS (real(kind=r4_kind))
+ missing_value_use = missing_value
+ TYPE IS (real(kind=r8_kind))
+ missing_value_use = real(missing_value)
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::register_static_field',&
+ & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
END IF
END IF
@@ -650,6 +670,14 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
allow_log = .TRUE.
END IF
+ ! Fatal error if range is present and its extent is not 2.
+ IF ( PRESENT(range) ) THEN
+ IF ( SIZE(range) .NE. 2 ) THEN
+ ! extent of range should be 2
+ CALL error_mesg ('diag_manager_mod::register_static_field', 'extent of range should be 2', FATAL)
+ END IF
+ END IF
+
! Namelist do_diag_field_log is by default false. Thus to log the
! registration of the data field, but the OPTIONAL parameter
! do_not_log == .FALSE. and the namelist variable
@@ -769,9 +797,18 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
END IF
IF ( PRESENT(range) ) THEN
- input_fields(field)%range = range
+ SELECT TYPE (range)
+ TYPE IS (real(kind=r4_kind))
+ range_use = range
+ TYPE IS (real(kind=r8_kind))
+ range_use = real(range)
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::register_static_field',&
+ & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+ input_fields(field)%range = range_use
! don't use the range if it is not a valid range
- input_fields(field)%range_present = range(2) .gt. range(1)
+ input_fields(field)%range_present = range_use(2) .gt. range_use(1)
ELSE
input_fields(field)%range = (/ 1., 0. /)
input_fields(field)%range_present = .FALSE.
@@ -1237,35 +1274,45 @@ END SUBROUTINE add_associated_files
!> @return true if send is successful
LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg)
INTEGER, INTENT(in) :: diag_field_id
- REAL, INTENT(in) :: field
+ CLASS(*), INTENT(in) :: field
TYPE(time_type), INTENT(in), OPTIONAL :: time
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
- REAL :: field_out(1, 1, 1)
+ REAL :: field_out(1, 1, 1) !< Local copy of field
! If diag_field_id is < 0 it means that this field is not registered, simply return
IF ( diag_field_id <= 0 ) THEN
send_data_0d = .FALSE.
RETURN
END IF
+
! First copy the data to a three d array with last element 1
- field_out(1, 1, 1) = field
+ SELECT TYPE (field)
+ TYPE IS (real(kind=r4_kind))
+ field_out(1, 1, 1) = field
+ TYPE IS (real(kind=r8_kind))
+ field_out(1, 1, 1) = real(field)
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_0d',&
+ & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+
send_data_0d = send_data_3d(diag_field_id, field_out, time, err_msg=err_msg)
END FUNCTION send_data_0d
!> @return true if send is successful
LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
INTEGER, INTENT(in) :: diag_field_id
- REAL, DIMENSION(:), INTENT(in) :: field
- REAL, INTENT(in), OPTIONAL :: weight
- REAL, INTENT(in), DIMENSION(:), OPTIONAL :: rmask
+ CLASS(*), DIMENSION(:), INTENT(in) :: field
+ CLASS(*), INTENT(in), OPTIONAL :: weight
+ CLASS(*), INTENT(in), DIMENSION(:), OPTIONAL :: rmask
TYPE (time_type), INTENT(in), OPTIONAL :: time
INTEGER, INTENT(in), OPTIONAL :: is_in, ie_in
LOGICAL, INTENT(in), DIMENSION(:), OPTIONAL :: mask
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
- REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out
- LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out
+ REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out !< Local copy of field
+ LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out !< Local copy of mask
! If diag_field_id is < 0 it means that this field is not registered, simply return
IF ( diag_field_id <= 0 ) THEN
@@ -1274,7 +1321,15 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie
END IF
! First copy the data to a three d array with last element 1
- field_out(:, 1, 1) = field
+ SELECT TYPE (field)
+ TYPE IS (real(kind=r4_kind))
+ field_out(:, 1, 1) = field
+ TYPE IS (real(kind=r8_kind))
+ field_out(:, 1, 1) = real(field)
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_1d',&
+ & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
! Default values for mask
IF ( PRESENT(mask) ) THEN
@@ -1283,7 +1338,18 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie
mask_out = .TRUE.
END IF
- IF ( PRESENT(rmask) ) WHERE (rmask < 0.5) mask_out(:, 1, 1) = .FALSE.
+ IF ( PRESENT(rmask) ) THEN
+ SELECT TYPE (rmask)
+ TYPE IS (real(kind=r4_kind))
+ WHERE (rmask < 0.5_r4_kind) mask_out(:, 1, 1) = .FALSE.
+ TYPE IS (real(kind=r8_kind))
+ WHERE (rmask < 0.5_r8_kind) mask_out(:, 1, 1) = .FALSE.
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_1d',&
+ & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+ END IF
+
IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN
IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN
send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,&
@@ -1306,16 +1372,16 @@ END FUNCTION send_data_1d
LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, &
& mask, rmask, ie_in, je_in, weight, err_msg)
INTEGER, INTENT(in) :: diag_field_id
- REAL, INTENT(in), DIMENSION(:,:) :: field
- REAL, INTENT(in), OPTIONAL :: weight
+ CLASS(*), INTENT(in), DIMENSION(:,:) :: field
+ CLASS(*), INTENT(in), OPTIONAL :: weight
TYPE (time_type), INTENT(in), OPTIONAL :: time
INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ie_in, je_in
LOGICAL, INTENT(in), DIMENSION(:,:), OPTIONAL :: mask
- REAL, INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask
+ CLASS(*), INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
- REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out
- LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out
+ REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out !< Local copy of field
+ LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out !< Local copy of mask
! If diag_field_id is < 0 it means that this field is not registered, simply return
IF ( diag_field_id <= 0 ) THEN
@@ -1324,7 +1390,15 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, &
END IF
! First copy the data to a three d array with last element 1
- field_out(:, :, 1) = field
+ SELECT TYPE (field)
+ TYPE IS (real(kind=r4_kind))
+ field_out(:, :, 1) = field
+ TYPE IS (real(kind=r8_kind))
+ field_out(:, :, 1) = real(field)
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_2d',&
+ & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
! Default values for mask
IF ( PRESENT(mask) ) THEN
@@ -1333,7 +1407,18 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, &
mask_out = .TRUE.
END IF
- IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) mask_out(:, :, 1) = .FALSE.
+ IF ( PRESENT(rmask) ) THEN
+ SELECT TYPE (rmask)
+ TYPE IS (real(kind=r4_kind))
+ WHERE ( rmask < 0.5_r4_kind ) mask_out(:, :, 1) = .FALSE.
+ TYPE IS (real(kind=r8_kind))
+ WHERE ( rmask < 0.5_r8_kind ) mask_out(:, :, 1) = .FALSE.
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_2d',&
+ & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+ END IF
+
IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN
send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1, mask=mask_out,&
& ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
@@ -1343,168 +1428,16 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, &
END IF
END FUNCTION send_data_2d
-#ifdef OVERLOAD_R8
-
- !> @return true if send is successful
- LOGICAL FUNCTION send_data_0d_r8(diag_field_id, field, time, err_msg)
- INTEGER, INTENT(in) :: diag_field_id
- REAL(r8_kind), INTENT(in) :: field
- TYPE(time_type), INTENT(in), OPTIONAL :: time
- CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
-
- REAL(r8_kind) :: field_out(1, 1, 1)
-
- ! If diag_field_id is < 0 it means that this field is not registered, simply return
- IF ( diag_field_id <= 0 ) THEN
- send_data_0d_r8 = .FALSE.
- RETURN
- END IF
- ! First copy the data to a three d array with last element 1
- field_out(1, 1, 1) = field
- send_data_0d_r8 = send_data_3d_r8(diag_field_id, field_out, time, err_msg=err_msg)
- END FUNCTION send_data_0d_r8
-
- !> @return true if send is successful
- LOGICAL FUNCTION send_data_1d_r8(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg)
- INTEGER, INTENT(in) :: diag_field_id
- REAL(r8_kind), DIMENSION(:), INTENT(in) :: field
- REAL, INTENT(in), OPTIONAL :: weight
- REAL, INTENT(in), DIMENSION(:), OPTIONAL :: rmask
- TYPE (time_type), INTENT(in), OPTIONAL :: time
- INTEGER, INTENT(in), OPTIONAL :: is_in, ie_in
- LOGICAL, INTENT(in), DIMENSION(:), OPTIONAL :: mask
- CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
-
- REAL(r8_kind), DIMENSION(SIZE(field(:)), 1, 1) :: field_out
- LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out
-
- ! If diag_field_id is < 0 it means that this field is not registered, simply return
- IF ( diag_field_id <= 0 ) THEN
- send_data_1d_r8 = .FALSE.
- RETURN
- END IF
-
- ! First copy the data to a three d array with last element 1
- field_out(:, 1, 1) = field
-
- ! Default values for mask
- IF ( PRESENT(mask) ) THEN
- mask_out(:, 1, 1) = mask
- ELSE
- mask_out = .TRUE.
- END IF
-
- IF ( PRESENT(rmask) ) WHERE (rmask < 0.5) mask_out(:, 1, 1) = .FALSE.
- IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN
- IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN
- send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,&
- & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
- ELSE
- send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, mask=mask_out,&
- & weight=weight, err_msg=err_msg)
- END IF
- ELSE
- IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN
- send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,&
- & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg)
- ELSE
- send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, weight=weight, err_msg=err_msg)
- END IF
- END IF
- END FUNCTION send_data_1d_r8
- !> @return true if send is successful
- LOGICAL FUNCTION send_data_2d_r8(diag_field_id, field, time, is_in, js_in, &
- & mask, rmask, ie_in, je_in, weight, err_msg)
- INTEGER, INTENT(in) :: diag_field_id
- REAL(r8_kind), INTENT(in), DIMENSION(:,:) :: field
- REAL, INTENT(in), OPTIONAL :: weight
- TYPE (time_type), INTENT(in), OPTIONAL :: time
- INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ie_in, je_in
- LOGICAL, INTENT(in), DIMENSION(:,:), OPTIONAL :: mask
- REAL, INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask
- CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
-
- REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out
- LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out
-
- ! If diag_field_id is < 0 it means that this field is not registered, simply return
- IF ( diag_field_id <= 0 ) THEN
- send_data_2d_r8 = .FALSE.
- RETURN
- END IF
-
- ! First copy the data to a three d array with last element 1
- field_out(:, :, 1) = field
-
- ! Default values for mask
- IF ( PRESENT(mask) ) THEN
- mask_out(:, :, 1) = mask
- ELSE
- mask_out = .TRUE.
- END IF
-
- IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) mask_out(:, :, 1) = .FALSE.
- IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN
- send_data_2d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1, mask=mask_out,&
- & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
- ELSE
- send_data_2d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,&
- & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg)
- END IF
- END FUNCTION send_data_2d_r8
-
- !> @return true if send is successful
- LOGICAL FUNCTION send_data_3d_r8(diag_field_id, field, time, is_in, js_in, ks_in, &
- & mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
- INTEGER, INTENT(in) :: diag_field_id
- REAL(r8_kind), INTENT(in), DIMENSION(:,:,:) :: field
- REAL, INTENT(in), OPTIONAL :: weight
- TYPE (time_type), INTENT(in), OPTIONAL :: time
- INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
- LOGICAL, INTENT(in), DIMENSION(:,:,:), OPTIONAL :: mask
- REAL, INTENT(in), DIMENSION(:,:,:),OPTIONAL :: rmask
- CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
-
- REAL, DIMENSION(SIZE(field,1),SIZE(field,2),size(field,3)) :: field_out
- LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),size(field,3)) :: mask_out
-
- ! If diag_field_id is < 0 it means that this field is not registered, simply return
- IF ( diag_field_id <= 0 ) THEN
- send_data_3d_r8 = .FALSE.
- RETURN
- END IF
-
- ! First copy the data to a three d array with last element 1
- field_out = field
-
- ! Default values for mask
- IF ( PRESENT(mask) ) THEN
- mask_out = mask
- ELSE
- mask_out = .TRUE.
- END IF
-
- IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) mask_out = .FALSE.
- IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN
- send_data_3d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=ks_in, mask=mask_out,&
- & ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
- ELSE
- send_data_3d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=ks_in,&
- & ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg)
- END IF
- END FUNCTION send_data_3d_r8
-#endif
-
!> @return true if send is successful
LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
& mask, rmask, ie_in, je_in, ke_in, weight, err_msg)
INTEGER, INTENT(in) :: diag_field_id
- REAL, DIMENSION(:,:,:), INTENT(in) :: field
- REAL, INTENT(in), OPTIONAL :: weight
+ CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field
+ CLASS(*), INTENT(in), OPTIONAL :: weight
TYPE (time_type), INTENT(in), OPTIONAL :: time
INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in
LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask
- REAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask
+ CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
REAL :: weight1
@@ -1538,6 +1471,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
CHARACTER(len=256) :: err_msg_local
CHARACTER(len=128) :: error_string, error_string1
+ REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field
+
! If diag_field_id is < 0 it means that this field is not registered, simply return
IF ( diag_field_id <= 0 ) THEN
send_data_3d = .FALSE.
@@ -1560,6 +1495,23 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
!!$ first_send_data_call = .FALSE.
!!$ END IF
+ ! First copy the data to a three d array
+ ALLOCATE(field_out(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status)
+ IF ( status .NE. 0 ) THEN
+ WRITE (err_msg_local, FMT='("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')&
+ & SIZE(field,1), SIZE(field,2), SIZE(field,3), status
+ IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN
+ END IF
+ SELECT TYPE (field)
+ TYPE IS (real(kind=r4_kind))
+ field_out = field
+ TYPE IS (real(kind=r8_kind))
+ field_out = real(field)
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_3d',&
+ & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+
! oor_mask is only used for checking out of range values.
ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status)
IF ( status .NE. 0 ) THEN
@@ -1573,7 +1525,18 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
ELSE
oor_mask = .TRUE.
END IF
- IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) oor_mask = .FALSE.
+
+ IF ( PRESENT(rmask) ) THEN
+ SELECT TYPE (rmask)
+ TYPE IS (real(kind=r4_kind))
+ WHERE ( rmask < 0.5_r4_kind ) oor_mask = .FALSE.
+ TYPE IS (real(kind=r8_kind))
+ WHERE ( rmask < 0.5_r8_kind ) oor_mask = .FALSE.
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_3d',&
+ & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+ END IF
! send_data works in either one or another of two modes.
! 1. Input field is a window (e.g. FMS physics)
@@ -1589,6 +1552,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( PRESENT(ie_in) ) THEN
IF ( .NOT.PRESENT(is_in) ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'ie_in present without is_in', err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1596,6 +1560,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN
IF ( fms_error_handler('diag_manager_modsend_data_3d',&
& 'is_in and ie_in present, but js_in present without je_in', err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1604,6 +1569,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( PRESENT(je_in) ) THEN
IF ( .NOT.PRESENT(js_in) ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'je_in present without js_in', err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1611,6 +1577,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d',&
& 'js_in and je_in present, but is_in present without ie_in', err_msg)) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1636,6 +1603,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
twohi = n1-(ie-is+1)
IF ( MOD(twohi,2) /= 0 ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in first dimension', err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1643,6 +1611,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
twohj = n2-(je-js+1)
IF ( MOD(twohj,2) /= 0 ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in second dimension', err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1667,7 +1636,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
! weight is for time averaging where each time level may has a different weight
IF ( PRESENT(weight) ) THEN
- weight1 = weight
+ SELECT TYPE (weight)
+ TYPE IS (real(kind=r4_kind))
+ weight1 = weight
+ TYPE IS (real(kind=r8_kind))
+ weight1 = real(weight)
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_3d',&
+ & 'The weight is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
ELSE
weight1 = 1.
END IF
@@ -1696,13 +1673,13 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
WRITE (error_string, '("[",ES14.5E3,",",ES14.5E3,"]")')&
& input_fields(diag_field_id)%range(1:2)
WRITE (error_string1, '("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')&
- & MINVAL(field(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)),&
- & MAXVAL(field(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke))
+ & MINVAL(field_out(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)),&
+ & MAXVAL(field_out(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke))
IF ( missvalue_present ) THEN
IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
- & ((field(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
- & field(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.&
- & field(f1:f2,f3:f4,ks:ke) .NE. missvalue)) ) THEN
+ & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
+ & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.&
+ & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) ) THEN
!
! A value for in field (Min: , Max: )
! is outside the range [,] and not equal to the missing
@@ -1719,8 +1696,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
END IF
ELSE
IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
- & (field(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
- & field(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) ) THEN
+ & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.&
+ & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) ) THEN
!
! A value for in field (Min: , Max: )
! is outside the range [,].
@@ -1770,7 +1747,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
time_min = output_fields(out_num)%time_min
! Sum output over time interval
time_sum = output_fields(out_num)%time_sum
- IF ( output_fields(out_num)%total_elements > SIZE(field(f1:f2,f3:f4,ks:ke)) ) THEN
+ IF ( output_fields(out_num)%total_elements > SIZE(field_out(f1:f2,f3:f4,ks:ke)) ) THEN
output_fields(out_num)%phys_window = .TRUE.
ELSE
output_fields(out_num)%phys_window = .FALSE.
@@ -1814,6 +1791,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
& TRIM(output_fields(out_num)%output_name)
IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//&
& ', time must be present when output frequency = EVERY_TIME', err_msg)) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1826,6 +1804,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
& TRIM(output_fields(out_num)%output_name)
IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//&
& ', time must be present for nonstatic field', err_msg)) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1845,6 +1824,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
& TRIM(output_fields(out_num)%output_name)
IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//&
& ' is skipped one time level in output data', err_msg)) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1856,6 +1836,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN
IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//TRIM(error_string)//&
& ', write EMPTY buffer', err_msg)) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1870,6 +1851,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
CALL check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1885,6 +1867,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
& TRIM(output_fields(out_num)%output_name)
IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//&
& ', regional output NOT supported with mask_variant', err_msg)) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1899,6 +1882,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -1914,11 +1898,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & (field(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & field(i-is+1+hi, j-js+1+hj, k) * weight1
+ & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
END IF
output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
@@ -1934,11 +1918,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k)*weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
END IF
output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
&output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
@@ -1958,11 +1942,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & (field(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & field(i-is+1+hi, j-js+1+hj, k) * weight1
+ & field_out(i-is+1+hi, j-js+1+hj, k) * weight1
END IF
output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1
@@ -1978,11 +1962,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k)*weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k)*weight1
END IF
output_fields(out_num)%counter(i-hi,j-hj,k,sample) =&
&output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1
@@ -1999,6 +1983,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
& TRIM(output_fields(out_num)%output_name)
IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//&
& ', variable mask but no missing value defined', err_msg)) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -2009,6 +1994,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
& TRIM(output_fields(out_num)%output_name)
IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//TRIM(error_string)//&
& ', variable mask but no mask given', err_msg)) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -2029,11 +2015,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i1,j1,k1,sample) =&
& output_fields(out_num)%buffer(i1,j1,k1,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) =&
& output_fields(out_num)%buffer(i1,j1,k1,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
@@ -2055,11 +2041,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i1,j1,k1,sample) =&
& output_fields(out_num)%buffer(i1,j1,k1,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) =&
& output_fields(out_num)%buffer(i1,j1,k1,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
@@ -2090,11 +2076,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
@@ -2112,11 +2098,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
@@ -2132,6 +2118,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -2145,11 +2132,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
@@ -2166,11 +2153,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
@@ -2214,10 +2201,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
j1 = j-l_start(2)-hj+1
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample)+ &
- & (field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample)+ &
- & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
+ & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
END IF
END IF
END DO
@@ -2231,10 +2218,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
j1 = j-l_start(2)-hj+1
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample)+ &
- & (field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample)+ &
- & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
+ & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
END IF
END IF
END DO
@@ -2259,11 +2246,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
- & (field(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
+ & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
- & field(f1:f2,f3:f4,ksr:ker)*weight1
+ & field_out(f1:f2,f3:f4,ksr:ker)*weight1
END IF
ELSE
!$OMP CRITICAL
@@ -2272,11 +2259,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
- & (field(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
+ & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +&
- & field(f1:f2,f3:f4,ksr:ker)*weight1
+ & field_out(f1:f2,f3:f4,ksr:ker)*weight1
END IF
!$OMP END CRITICAL
END IF
@@ -2286,6 +2273,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '') THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -2295,22 +2283,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
- & (field(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
+ & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
- & field(f1:f2,f3:f4,ks:ke)*weight1
+ & field_out(f1:f2,f3:f4,ks:ke)*weight1
END IF
ELSE
!$OMP CRITICAL
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
- & (field(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
+ & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
- & field(f1:f2,f3:f4,ks:ke)*weight1
+ & field_out(f1:f2,f3:f4,ks:ke)*weight1
END IF
!$OMP END CRITICAL
END IF
@@ -2331,15 +2319,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj) THEN
i1 = i-l_start(1)-hi+1
j1= j-l_start(2)-hj+1
- IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i1,j1,k1,sample) =&
& output_fields(out_num)%buffer(i1,j1,k1,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) =&
& output_fields(out_num)%buffer(i1,j1,k1,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
@@ -2357,15 +2345,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj) THEN
i1 = i-l_start(1)-hi+1
j1= j-l_start(2)-hj+1
- IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i1,j1,k1,sample) =&
& output_fields(out_num)%buffer(i1,j1,k1,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) =&
& output_fields(out_num)%buffer(i1,j1,k1,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
@@ -2389,7 +2377,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
outer0: DO k = l_start(3), l_end(3)
DO j=l_start(2)+hj, l_end(2)+hj
DO i=l_start(1)+hi, l_end(1)+hi
- IF ( field(i,j,k) /= missvalue ) THEN
+ IF ( field_out(i,j,k) /= missvalue ) THEN
output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1
EXIT outer0
END IF
@@ -2406,15 +2394,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
k1 = k - ksr + 1
DO j=js, je
DO i=is, ie
- IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
@@ -2430,15 +2418,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
k1 = k - ksr + 1
DO j=js, je
DO i=is, ie
- IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue
@@ -2453,7 +2441,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
k1=k-ksr+1
DO j=f3, f4
DO i=f1, f2
- IF ( field(i,j,k) /= missvalue ) THEN
+ IF ( field_out(i,j,k) /= missvalue ) THEN
output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1
EXIT outer3
END IF
@@ -2467,6 +2455,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -2476,15 +2465,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
DO k=ks, ke
DO j=js, je
DO i=is, ie
- IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
@@ -2497,15 +2486,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
DO k=ks, ke
DO j=js, je
DO i=is, ie
- IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =&
& output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +&
- & field(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field_out(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue
@@ -2519,7 +2508,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
outer1: DO k=ks, ke
DO j=f3, f4
DO i=f1, f2
- IF ( field(i,j,k) /= missvalue ) THEN
+ IF ( field_out(i,j,k) /= missvalue ) THEN
output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1
EXIT outer1
END IF
@@ -2538,10 +2527,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
j1= j-l_start(2)-hj+1
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample) +&
- & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
+ & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
END IF
END IF
END DO
@@ -2555,10 +2544,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
j1= j-l_start(2)-hj+1
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample) +&
- & (field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
+ & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample) +&
- & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
+ & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
END IF
END IF
END DO
@@ -2584,22 +2573,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
- & (field(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
+ & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
- & field(f1:f2,f3:f4,ksr:ker)*weight1
+ & field_out(f1:f2,f3:f4,ksr:ker)*weight1
END IF
ELSE
!$OMP CRITICAL
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
- & (field(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
+ & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
- & field(f1:f2,f3:f4,ksr:ker)*weight1
+ & field_out(f1:f2,f3:f4,ksr:ker)*weight1
END IF
!$OMP END CRITICAL
END IF
@@ -2609,6 +2598,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -2618,22 +2608,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
- & (field(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
+ & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
- & field(f1:f2,f3:f4,ks:ke)*weight1
+ & field_out(f1:f2,f3:f4,ks:ke)*weight1
END IF
ELSE
!$OMP CRITICAL
IF ( pow_value /= 1 ) THEN
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
- & (field(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
+ & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
ELSE
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =&
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +&
- & field(f1:f2,f3:f4,ks:ke)*weight1
+ & field_out(f1:f2,f3:f4,ks:ke)*weight1
END IF
!$OMP END CRITICAL
END IF
@@ -2665,8 +2655,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
i1 = i-l_start(1)-hi+1
j1= j-l_start(2)-hj+1
IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND.&
- & field(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample)) THEN
- output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k)
+ & field_out(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample)) THEN
+ output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
END IF
END IF
END DO
@@ -2677,22 +2667,23 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
ksr = l_start(3)
ker = l_end(3)
WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. &
- & field(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample))&
- & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker)
+ & field_out(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample))&
+ & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
ELSE
IF ( debug_diag_manager ) THEN
CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
END IF
END IF
WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND.&
- & field(f1:f2,f3:f4,ks:ke)>output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample))&
- & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke)
+ & field_out(f1:f2,f3:f4,ks:ke)>output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample))&
+ & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
END IF
ELSE
IF ( need_compute ) THEN
@@ -2703,8 +2694,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
i1 = i-l_start(1)-hi+1
j1 = j-l_start(2)-hj+1
- IF ( field(i-is+1+hi,j-js+1+hj,k) > output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
- output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k)
+ IF ( field_out(i-is+1+hi,j-js+1+hj,k) > output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
+ output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
END IF
END IF
END DO
@@ -2714,21 +2705,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
ELSE IF ( reduced_k_range ) THEN
ksr = l_start(3)
ker = l_end(3)
- WHERE ( field(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
- & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker)
+ WHERE ( field_out(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
+ & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
ELSE
IF ( debug_diag_manager ) THEN
CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
END IF
END IF
- WHERE ( field(f1:f2,f3:f4,ks:ke) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
- & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke)
+ WHERE ( field_out(f1:f2,f3:f4,ks:ke) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
+ & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
END IF
END IF
output_fields(out_num)%count_0d(sample) = 1
@@ -2743,8 +2735,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
i1 = i-l_start(1)-hi+1
j1 = j-l_start(2)-hj+1
IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND.&
- & field(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
- output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k)
+ & field_out(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
+ output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
END IF
END IF
END DO
@@ -2755,22 +2747,23 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
ksr= l_start(3)
ker= l_end(3)
WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND.&
- & field(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample)) &
- & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker)
+ & field_out(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample)) &
+ & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
ELSE
IF ( debug_diag_manager ) THEN
CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
END IF
END IF
WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND.&
- & field(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
- & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke)
+ & field_out(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) &
+ & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
END IF
ELSE
IF ( need_compute ) THEN
@@ -2781,8 +2774,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj) THEN
i1 = i-l_start(1)-hi+1
j1= j-l_start(2)-hj+1
- IF ( field(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
- output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k)
+ IF ( field_out(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN
+ output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k)
END IF
END IF
END DO
@@ -2792,21 +2785,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
ELSE IF ( reduced_k_range ) THEN
ksr= l_start(3)
ker= l_end(3)
- WHERE ( field(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
- output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker)
+ WHERE ( field_out(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) &
+ output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
ELSE
IF ( debug_diag_manager ) THEN
CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
END IF
END IF
- WHERE ( field(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
- & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke)
+ WHERE ( field_out(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )&
+ & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
END IF
END IF
output_fields(out_num)%count_0d(sample) = 1
@@ -2823,7 +2817,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN
output_fields(out_num)%buffer(i1,j1,k1,sample) = &
output_fields(out_num)%buffer(i1,j1,k1,sample) + &
- field(i-is+1+hi,j-js+1+hj,k)
+ field_out(i-is+1+hi,j-js+1+hj,k)
END IF
END IF
END DO
@@ -2835,13 +2829,14 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
ker= l_end(3)
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
- & field(f1:f2,f3:f4,ksr:ker)
+ & field_out(f1:f2,f3:f4,ksr:ker)
ELSE
IF ( debug_diag_manager ) THEN
CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -2850,7 +2845,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
WHERE ( mask(f1:f2,f3:f4,ks:ke) ) &
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
- & field(f1:f2,f3:f4,ks:ke)
+ & field_out(f1:f2,f3:f4,ks:ke)
END IF
ELSE
IF ( need_compute ) THEN
@@ -2863,7 +2858,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
j1= j-l_start(2)-hj+1
output_fields(out_num)%buffer(i1,j1,k1,sample) = &
& output_fields(out_num)%buffer(i1,j1,k1,sample) + &
- & field(i-is+1+hi,j-js+1+hj,k)
+ & field_out(i-is+1+hi,j-js+1+hj,k)
END IF
END DO
END DO
@@ -2873,13 +2868,14 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
ker= l_end(3)
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = &
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + &
- & field(f1:f2,f3:f4,ksr:ker)
+ & field_out(f1:f2,f3:f4,ksr:ker)
ELSE
IF ( debug_diag_manager ) THEN
CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -2887,7 +2883,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
END IF
output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = &
& output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + &
- & field(f1:f2,f3:f4,ks:ke)
+ & field_out(f1:f2,f3:f4,ks:ke)
END IF
END IF
output_fields(out_num)%count_0d(sample) = 1
@@ -2899,7 +2895,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
i1 = i-l_start(1)-hi+1
j1 = j-l_start(2)-hj+1
- output_fields(out_num)%buffer(i1,j1,:,sample) = field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
+ output_fields(out_num)%buffer(i1,j1,:,sample) = field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
END IF
END DO
END DO
@@ -2907,19 +2903,20 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
ELSE IF ( reduced_k_range ) THEN
ksr = l_start(3)
ker = l_end(3)
- output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker)
+ output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker)
ELSE
IF ( debug_diag_manager ) THEN
CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke)
CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
END IF
END IF
- output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke)
+ output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke)
END IF
IF ( PRESENT(mask) .AND. missvalue_present ) THEN
@@ -2966,6 +2963,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
CALL check_bounds_are_exact_static(out_num, diag_field_id, err_msg=err_msg_local)
IF ( err_msg_local /= '' ) THEN
IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg)) THEN
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
RETURN
END IF
@@ -2975,45 +2973,97 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, &
! If rmask and missing value present, then insert missing value
IF ( PRESENT(rmask) .AND. missvalue_present ) THEN
IF ( need_compute ) THEN
- DO k = l_start(3), l_end(3)
- k1 = k - l_start(3) + 1
- DO j = js, je
- DO i = is, ie
- IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
- i1 = i-l_start(1)-hi+1
- j1 = j-l_start(2)-hj+1
- IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5 ) &
- & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
- END IF
+ SELECT TYPE (rmask)
+ TYPE IS (real(kind=r4_kind))
+ DO k = l_start(3), l_end(3)
+ k1 = k - l_start(3) + 1
+ DO j = js, je
+ DO i = is, ie
+ IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
+ i1 = i-l_start(1)-hi+1
+ j1 = j-l_start(2)-hj+1
+ IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
+ & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
+ END IF
+ END DO
END DO
END DO
- END DO
+ TYPE IS (real(kind=r8_kind))
+ DO k = l_start(3), l_end(3)
+ k1 = k - l_start(3) + 1
+ DO j = js, je
+ DO i = is, ie
+ IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN
+ i1 = i-l_start(1)-hi+1
+ j1 = j-l_start(2)-hj+1
+ IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
+ & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
+ END IF
+ END DO
+ END DO
+ END DO
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_3d',&
+ & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
ELSE IF ( reduced_k_range ) THEN
ksr= l_start(3)
ker= l_end(3)
- DO k= ksr, ker
- k1 = k - ksr + 1
- DO j=js, je
- DO i=is, ie
- IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5 ) &
- & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
+ SELECT TYPE (rmask)
+ TYPE IS (real(kind=r4_kind))
+ DO k= ksr, ker
+ k1 = k - ksr + 1
+ DO j=js, je
+ DO i=is, ie
+ IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
+ & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
+ END DO
END DO
END DO
- END DO
+ TYPE IS (real(kind=r8_kind))
+ DO k= ksr, ker
+ k1 = k - ksr + 1
+ DO j=js, je
+ DO i=is, ie
+ IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
+ & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue
+ END DO
+ END DO
+ END DO
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_3d',&
+ & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
ELSE
- DO k=ks, ke
- DO j=js, je
- DO i=is, ie
- IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5 ) &
- & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
+ SELECT TYPE (rmask)
+ TYPE IS (real(kind=r4_kind))
+ DO k=ks, ke
+ DO j=js, je
+ DO i=is, ie
+ IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) &
+ & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
+ END DO
END DO
END DO
- END DO
+ TYPE IS (real(kind=r8_kind))
+ DO k=ks, ke
+ DO j=js, je
+ DO i=is, ie
+ IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) &
+ & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue
+ END DO
+ END DO
+ END DO
+ CLASS DEFAULT
+ CALL error_mesg ('diag_manager_mod::send_data_3d',&
+ & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
END IF
END IF
END DO num_out_fields
+ DEALLOCATE(field_out)
DEALLOCATE(oor_mask)
END FUNCTION send_data_3d
diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90
index 9b7f6f0f99..56927fd2dc 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -631,8 +631,8 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,&
INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs
CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field.
CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field.
- REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value value.
- REAL, DIMENSION(2), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field.
+ CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value.
+ CLASS(*), DIMENSION(:), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field.
LOGICAL, OPTIONAL, INTENT(in) :: dynamic !< .TRUE. if field is not static.
! ---- local vars
@@ -642,10 +642,20 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,&
CHARACTER(len=1) :: sep = '|'
CHARACTER(len=256) :: axis_name, axes_list
INTEGER :: i
+ REAL :: missing_value_use !< Local copy of missing_value
+ REAL, DIMENSION(2) :: range_use !< Local copy of range
IF ( .NOT.do_diag_field_log ) RETURN
IF ( mpp_pe().NE.mpp_root_pe() ) RETURN
+ ! Fatal error if range is present and its extent is not 2.
+ IF ( PRESENT(range) ) THEN
+ IF ( SIZE(range) .NE. 2 ) THEN
+ ! extent of range should be 2
+ CALL error_mesg ('diag_util_mod::log_diag_field_info', 'extent of range should be 2', FATAL)
+ END IF
+ END IF
+
lmodule = TRIM(module_name)
lfield = TRIM(field_name)
@@ -667,15 +677,33 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,&
IF ( use_cmor ) THEN
WRITE (lmissval,*) CMOR_MISSING_VALUE
ELSE
- WRITE (lmissval,*) missing_value
+ SELECT TYPE (missing_value)
+ TYPE IS (real(kind=r4_kind))
+ missing_value_use = missing_value
+ TYPE IS (real(kind=r8_kind))
+ missing_value_use = real(missing_value)
+ CLASS DEFAULT
+ CALL error_mesg ('diag_util_mod::log_diag_field_info',&
+ & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+ WRITE (lmissval,*) missing_value_use
END IF
ELSE
lmissval = ''
ENDIF
IF ( PRESENT(range) ) THEN
- WRITE (lmin,*) range(1)
- WRITE (lmax,*) range(2)
+ SELECT TYPE (range)
+ TYPE IS (real(kind=r4_kind))
+ range_use = range
+ TYPE IS (real(kind=r8_kind))
+ range_use = real(range)
+ CLASS DEFAULT
+ CALL error_mesg ('diag_util_mod::log_diag_field_info',&
+ & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ END SELECT
+ WRITE (lmin,*) range_use(1)
+ WRITE (lmax,*) range_use(2)
ELSE
lmin = ''
lmax = ''
diff --git a/sat_vapor_pres/sat_vapor_pres.F90 b/sat_vapor_pres/sat_vapor_pres.F90
index c92e134a94..054860e530 100644
--- a/sat_vapor_pres/sat_vapor_pres.F90
+++ b/sat_vapor_pres/sat_vapor_pres.F90
@@ -194,6 +194,8 @@ module sat_vapor_pres_mod
lookup_des3_k, lookup_es3_des3_k, &
compute_qs_k, compute_mrs_k
+ use platform_mod, only: r4_kind, r8_kind
+
implicit none
private
@@ -739,8 +741,8 @@ module sat_vapor_pres_mod
!
subroutine lookup_es_0d ( temp, esat, err_msg )
- real, intent(in) :: temp
- real, intent(out) :: esat
+ class(*), intent(in) :: temp
+ class(*), intent(out) :: esat
character(len=*), intent(out), optional :: err_msg
integer :: nbad
@@ -771,8 +773,8 @@ end subroutine lookup_es_0d
!
subroutine lookup_es_1d ( temp, esat, err_msg )
- real, intent(in) :: temp(:)
- real, intent(out) :: esat(:)
+ class(*), intent(in) :: temp(:)
+ class(*), intent(out) :: esat(:)
character(len=*), intent(out), optional :: err_msg
character(len=54) :: err_msg_local
@@ -807,8 +809,8 @@ end subroutine lookup_es_1d
!
subroutine lookup_es_2d ( temp, esat, err_msg )
- real, intent(in) :: temp(:,:)
- real, intent(out) :: esat(:,:)
+ class(*), intent(in) :: temp(:,:)
+ class(*), intent(out) :: esat(:,:)
character(len=*), intent(out), optional :: err_msg
character(len=54) :: err_msg_local
@@ -843,8 +845,8 @@ end subroutine lookup_es_2d
!
subroutine lookup_es_3d ( temp, esat, err_msg )
- real, intent(in) :: temp(:,:,:)
- real, intent(out) :: esat(:,:,:)
+ class(*), intent(in) :: temp(:,:,:)
+ class(*), intent(out) :: esat(:,:,:)
character(len=*), intent(out), optional :: err_msg
integer :: nbad
@@ -1975,10 +1977,10 @@ end subroutine lookup_es3_des3_3d
subroutine compute_qs_0d ( temp, press, qsat, q, hc, dqsdT, esat, &
err_msg, es_over_liq, es_over_liq_and_ice )
- real, intent(in) :: temp, press
- real, intent(out) :: qsat
- real, intent(in), optional :: q, hc
- real, intent(out), optional :: dqsdT, esat
+ class(*), intent(in) :: temp, press
+ class(*), intent(out) :: qsat
+ class(*), intent(in), optional :: q, hc
+ class(*), intent(out), optional :: dqsdT, esat
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
@@ -2033,11 +2035,11 @@ end subroutine compute_qs_0d
subroutine compute_qs_1d ( temp, press, qsat, q, hc, dqsdT, esat, &
err_msg, es_over_liq, es_over_liq_and_ice )
- real, intent(in) :: temp(:), press(:)
- real, intent(out) :: qsat(:)
- real, intent(in), optional :: q(:)
-real, intent(in), optional :: hc
- real, intent(out), optional :: dqsdT(:), esat(:)
+ class(*), intent(in) :: temp(:), press(:)
+ class(*), intent(out) :: qsat(:)
+ class(*), intent(in), optional :: q(:)
+ class(*), intent(in), optional :: hc
+ class(*), intent(out), optional :: dqsdT(:), esat(:)
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
@@ -2095,11 +2097,11 @@ end subroutine compute_qs_1d
subroutine compute_qs_2d ( temp, press, qsat, q, hc, dqsdT, esat, &
err_msg, es_over_liq, es_over_liq_and_ice )
- real, intent(in) :: temp(:,:), press(:,:)
- real, intent(out) :: qsat(:,:)
- real, intent(in), optional :: q(:,:)
- real, intent(in), optional :: hc
- real, intent(out), optional :: dqsdT(:,:), esat(:,:)
+ class(*), intent(in) :: temp(:,:), press(:,:)
+ class(*), intent(out) :: qsat(:,:)
+ class(*), intent(in), optional :: q(:,:)
+ class(*), intent(in), optional :: hc
+ class(*), intent(out), optional :: dqsdT(:,:), esat(:,:)
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
@@ -2156,11 +2158,11 @@ end subroutine compute_qs_2d
subroutine compute_qs_3d ( temp, press, qsat, q, hc, dqsdT, esat, &
err_msg, es_over_liq, es_over_liq_and_ice )
- real, intent(in) :: temp(:,:,:), press(:,:,:)
- real, intent(out) :: qsat(:,:,:)
- real, intent(in), optional :: q(:,:,:)
- real, intent(in), optional :: hc
- real, intent(out), optional :: dqsdT(:,:,:), esat(:,:,:)
+ class(*), intent(in) :: temp(:,:,:), press(:,:,:)
+ class(*), intent(out) :: qsat(:,:,:)
+ class(*), intent(in), optional :: q(:,:,:)
+ class(*), intent(in), optional :: hc
+ class(*), intent(out), optional :: dqsdT(:,:,:), esat(:,:,:)
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
@@ -2608,131 +2610,245 @@ end subroutine sat_vapor_pres_init
!#######################################################################
function check_1d ( temp ) result ( nbad )
- real , intent(in) :: temp(:)
+ class(*), intent(in) :: temp(:)
integer :: nbad, ind, i
nbad = 0
- do i = 1, size(temp,1)
- ind = int(dtinv*(temp(i)-tmin+teps))
- if (ind < 0 .or. ind > nlim) nbad = nbad+1
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ do i = 1, size(temp,1)
+ ind = int(dtinv*(temp(i)-tmin+teps))
+ if (ind < 0 .or. ind > nlim) nbad = nbad+1
+ enddo
+ type is (real(kind=r8_kind))
+ do i = 1, size(temp,1)
+ ind = int(dtinv*(temp(i)-tmin+teps))
+ if (ind < 0 .or. ind > nlim) nbad = nbad+1
+ enddo
+ class default
+ call error_mesg ('sat_vapor_pres_mod::check_1d',&
+ & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
end function check_1d
!------------------------------------------------
function check_2d ( temp ) result ( nbad )
- real , intent(in) :: temp(:,:)
+ class(*), intent(in) :: temp(:,:)
integer :: nbad
integer :: j
- nbad = 0
- do j = 1, size(temp,2)
- nbad = nbad + check_1d ( temp(:,j) )
- enddo
+ nbad = 0
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ do j = 1, size(temp,2)
+ nbad = nbad + check_1d ( temp(:,j) )
+ enddo
+ type is (real(kind=r8_kind))
+ do j = 1, size(temp,2)
+ nbad = nbad + check_1d ( temp(:,j) )
+ enddo
+ class default
+ call error_mesg ('sat_vapor_pres_mod::check_2d',&
+ & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
end function check_2d
!#######################################################################
subroutine temp_check_1d ( temp )
- real , intent(in) :: temp(:)
+ class(*), intent(in) :: temp(:)
integer :: i, unit
unit = stdoutunit
- write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1))
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1))
+ type is (real(kind=r8_kind))
+ write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1))
+ class default
+ call error_mesg ('sat_vapor_pres_mod::temp_check_1d',&
+ & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
end subroutine temp_check_1d
!--------------------------------------------------------------
subroutine temp_check_2d ( temp )
- real , intent(in) :: temp(:,:)
+ class(*), intent(in) :: temp(:,:)
integer :: i, j, unit
unit = stdoutunit
- write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1))
- write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2))
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1))
+ write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2))
+ type is (real(kind=r8_kind))
+ write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1))
+ write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2))
+ class default
+ call error_mesg ('sat_vapor_pres_mod::temp_check_2d',&
+ & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
end subroutine temp_check_2d
!--------------------------------------------------------------
subroutine temp_check_3d ( temp )
- real, intent(in) :: temp(:,:,:)
+ class(*), intent(in) :: temp(:,:,:)
integer :: i, j, k, unit
unit = stdoutunit
- write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1))
- write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2))
- write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3))
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1))
+ write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2))
+ write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3))
+ type is (real(kind=r8_kind))
+ write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1))
+ write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2))
+ write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3))
+ class default
+ call error_mesg ('sat_vapor_pres_mod::temp_check_3d',&
+ & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
end subroutine temp_check_3d
!#######################################################################
subroutine show_all_bad_0d ( temp )
- real , intent(in) :: temp
+ class(*), intent(in) :: temp
integer :: ind, unit
unit = stdoutunit
- ind = int(dtinv*(temp-tmin+teps))
- if (ind < 0 .or. ind > nlim) then
- write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe()
- endif
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ ind = int(dtinv*(temp-tmin+teps))
+ if (ind < 0 .or. ind > nlim) then
+ write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe()
+ endif
+ type is (real(kind=r8_kind))
+ ind = int(dtinv*(temp-tmin+teps))
+ if (ind < 0 .or. ind > nlim) then
+ write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe()
+ endif
+ class default
+ call error_mesg ('sat_vapor_pres_mod::show_all_bad_0d',&
+ & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
end subroutine show_all_bad_0d
!--------------------------------------------------------------
subroutine show_all_bad_1d ( temp )
- real , intent(in) :: temp(:)
+ class(*), intent(in) :: temp(:)
integer :: i, ind, unit
unit = stdoutunit
- do i=1,size(temp)
- ind = int(dtinv*(temp(i)-tmin+teps))
- if (ind < 0 .or. ind > nlim) then
- write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe()
- endif
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ do i=1,size(temp)
+ ind = int(dtinv*(temp(i)-tmin+teps))
+ if (ind < 0 .or. ind > nlim) then
+ write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe()
+ endif
+ enddo
+ type is (real(kind=r8_kind))
+ do i=1,size(temp)
+ ind = int(dtinv*(temp(i)-tmin+teps))
+ if (ind < 0 .or. ind > nlim) then
+ write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe()
+ endif
+ enddo
+ class default
+ call error_mesg ('sat_vapor_pres_mod::show_all_bad_1d',&
+ & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
end subroutine show_all_bad_1d
!--------------------------------------------------------------
subroutine show_all_bad_2d ( temp )
- real , intent(in) :: temp(:,:)
+ class(*), intent(in) :: temp(:,:)
integer :: i, j, ind, unit
unit = stdoutunit
- do j=1,size(temp,2)
- do i=1,size(temp,1)
- ind = int(dtinv*(temp(i,j)-tmin+teps))
- if (ind < 0 .or. ind > nlim) then
- write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe()
- endif
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ do j=1,size(temp,2)
+ do i=1,size(temp,1)
+ ind = int(dtinv*(temp(i,j)-tmin+teps))
+ if (ind < 0 .or. ind > nlim) then
+ write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe()
+ endif
+ enddo
+ enddo
+ type is (real(kind=r8_kind))
+ do j=1,size(temp,2)
+ do i=1,size(temp,1)
+ ind = int(dtinv*(temp(i,j)-tmin+teps))
+ if (ind < 0 .or. ind > nlim) then
+ write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe()
+ endif
+ enddo
+ enddo
+ class default
+ call error_mesg ('sat_vapor_pres_mod::show_all_bad_2d',&
+ & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
end subroutine show_all_bad_2d
!--------------------------------------------------------------
subroutine show_all_bad_3d ( temp )
- real, intent(in) :: temp(:,:,:)
+ class(*), intent(in) :: temp(:,:,:)
integer :: i, j, k, ind, unit
unit = stdoutunit
- do k=1,size(temp,3)
- do j=1,size(temp,2)
- do i=1,size(temp,1)
- ind = int(dtinv*(temp(i,j,k)-tmin+teps))
- if (ind < 0 .or. ind > nlim) then
- write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe()
- endif
- enddo
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ do k=1,size(temp,3)
+ do j=1,size(temp,2)
+ do i=1,size(temp,1)
+ ind = int(dtinv*(temp(i,j,k)-tmin+teps))
+ if (ind < 0 .or. ind > nlim) then
+ write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe()
+ endif
+ enddo
+ enddo
+ enddo
+ type is (real(kind=r8_kind))
+ do k=1,size(temp,3)
+ do j=1,size(temp,2)
+ do i=1,size(temp,1)
+ ind = int(dtinv*(temp(i,j,k)-tmin+teps))
+ if (ind < 0 .or. ind > nlim) then
+ write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe()
+ endif
+ enddo
+ enddo
+ enddo
+ class default
+ call error_mesg ('sat_vapor_pres_mod::show_all_bad_3d',&
+ & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
end subroutine show_all_bad_3d
diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90
index a9662a7d3b..3a1ba4f43b 100644
--- a/sat_vapor_pres/sat_vapor_pres_k.F90
+++ b/sat_vapor_pres/sat_vapor_pres_k.F90
@@ -50,6 +50,9 @@ module sat_vapor_pres_k_mod
! not be a fortran module. This complicates things greatly for questionable
! benefit and could be done as a second step anyway, if necessary.
+ use fms_mod, only: error_mesg, FATAL
+ use platform_mod, only: r4_kind, r8_kind
+
implicit none
private
@@ -475,85 +478,323 @@ end function compute_es_liq_ice_k
subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, &
dqsdT, esat, es_over_liq, es_over_liq_and_ice)
- real, intent(in), dimension(:,:,:) :: temp, press
- real, intent(in) :: eps, zvir
- real, intent(out), dimension(:,:,:) :: qs
- integer, intent(out) :: nbad
- real, intent(in), dimension(:,:,:), optional :: q
- real, intent(in), optional :: hc
- real, intent(out), dimension(:,:,:), optional :: dqsdT, esat
- logical,intent(in), optional :: es_over_liq
- logical,intent(in), optional :: es_over_liq_and_ice
-
- real, dimension(size(temp,1), size(temp,2), size(temp,3)) :: &
- esloc, desat, denom
+ class(*), intent(in), dimension(:,:,:) :: temp, press
+ real, intent(in) :: eps, zvir
+ class(*), intent(out), dimension(:,:,:) :: qs
+ integer, intent(out) :: nbad
+ class(*), intent(in), dimension(:,:,:), optional :: q
+ class(*), intent(in), optional :: hc
+ class(*), intent(out), dimension(:,:,:), optional :: dqsdT, esat
+ logical,intent(in), optional :: es_over_liq
+ logical,intent(in), optional :: es_over_liq_and_ice
+
+ real(kind=r4_kind), allocatable, dimension(:,:,:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments
+ real(kind=r8_kind), allocatable, dimension(:,:,:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments
integer :: i, j, k
real :: hc_loc
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (press)
+ type is (real(kind=r4_kind))
+ select type (qs)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (press)
+ type is (real(kind=r8_kind))
+ select type (qs)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL)
+ end if
+
+ if (present(q)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (q)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (q)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL)
+ end if
if (present(hc)) then
- hc_loc = hc
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (hc)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (hc)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL)
+ end if
+
+ if (present(dqsdT)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL)
+ end if
+
+ if (present(esat)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ allocate(esloc_r4(size(temp,1), size(temp,2), size(temp,3)))
+ allocate(desat_r4(size(temp,1), size(temp,2), size(temp,3)))
+ allocate(denom_r4(size(temp,1), size(temp,2), size(temp,3)))
+ type is (real(kind=r8_kind))
+ allocate(esloc_r8(size(temp,1), size(temp,2), size(temp,3)))
+ allocate(desat_r8(size(temp,1), size(temp,2), size(temp,3)))
+ allocate(denom_r8(size(temp,1), size(temp,2), size(temp,3)))
+ end select
+
+ if (present(hc)) then
+ select type (hc)
+ type is (real(kind=r4_kind))
+ hc_loc = hc
+ type is (real(kind=r8_kind))
+ hc_loc = real(hc)
+ end select
else
hc_loc = 1.0
endif
- if (present(es_over_liq)) then
- if (present (dqsdT)) then
- call lookup_es2_des2_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
- else
- call lookup_es2_k (temp, esloc, nbad)
- endif
- else if (present(es_over_liq_and_ice)) then
- if (present (dqsdT)) then
- call lookup_es3_des3_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
- else
- call lookup_es3_k (temp, esloc, nbad)
- endif
- else
- if (present (dqsdT)) then
- call lookup_es_des_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
+
+ if (present(es_over_liq)) then
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es2_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es2_k (temp, esloc_r8, nbad)
+ end select
+ endif
+ else if (present(es_over_liq_and_ice)) then
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es3_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es3_k (temp, esloc_r8, nbad)
+ end select
+ endif
else
- call lookup_es_k (temp, esloc, nbad)
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es_k (temp, esloc_r8, nbad)
+ end select
+ endif
endif
- endif
- esloc = esloc*hc_loc
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ esloc_r8 = esloc_r8*hc_loc
+ end select
+
if (present (esat)) then
- esat = esloc
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = esloc_r4
+ type is (real(kind=r8_kind))
+ esat = esloc_r8
+ end select
endif
+
if (nbad == 0) then
- if (present (q) .and. use_exact_qs) then
- qs = (1.0 + zvir*q)*eps*esloc/press
- if (present (dqsdT)) then
- dqsdT = (1.0 + zvir*q)*eps*desat/press
- endif
- else ! (present(q))
- denom = press - (1.0 - eps)*esloc
- do k=1,size(qs,3)
- do j=1,size(qs,2)
- do i=1,size(qs,1)
- if (denom(i,j,k) > 0.0) then
- qs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k)
- else
- qs(i,j,k) = eps
+ select type (press)
+ type is (real(kind=r4_kind))
+ select type (qs)
+ type is (real(kind=r4_kind))
+ if (present (q) .and. use_exact_qs) then
+ select type (q)
+ type is (real(kind=r4_kind))
+ qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press
+ end select
endif
+ end select
+ else ! (present(q))
+ denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4
+ do k=1,size(qs,3)
+ do j=1,size(qs,2)
+ do i=1,size(qs,1)
+ if (denom_r4(i,j,k) > 0.0_r4_kind) then
+ qs(i,j,k) = real(eps, kind=r4_kind)*esloc_r4(i,j,k)/denom_r4(i,j,k)
+ else
+ qs(i,j,k) = real(eps, kind=r4_kind)
+ endif
+ end do
+ end do
end do
- end do
- end do
- if (present (dqsdT)) then
- dqsdT = eps*press*desat/denom**2
- endif
- endif ! (present(q))
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2
+ end select
+ endif
+ endif ! (present(q))
+ end select
+ type is (real(kind=r8_kind))
+ select type (qs)
+ type is (real(kind=r8_kind))
+ if (present (q) .and. use_exact_qs) then
+ select type (q)
+ type is (real(kind=r8_kind))
+ qs = (1.0 + zvir*q)*eps*esloc_r8/press
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ dqsdT = (1.0 + zvir*q)*eps*desat_r8/press
+ end select
+ endif
+ end select
+ else ! (present(q))
+ denom_r8 = press - (1.0 - eps)*esloc_r8
+ do k=1,size(qs,3)
+ do j=1,size(qs,2)
+ do i=1,size(qs,1)
+ if (denom_r8(i,j,k) > 0.0) then
+ qs(i,j,k) = eps*esloc_r8(i,j,k)/denom_r8(i,j,k)
+ else
+ qs(i,j,k) = eps
+ endif
+ end do
+ end do
+ end do
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ dqsdT = eps*press*desat_r8/denom_r8**2
+ end select
+ endif
+ endif ! (present(q))
+ end select
+ end select
else ! (nbad = 0)
- qs = -999.
+ select type (qs)
+ type is (real(kind=r4_kind))
+ qs = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ qs = -999.
+ end select
if (present (dqsdT)) then
- dqsdT = -999.
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ dqsdT = -999.
+ end select
endif
if (present (esat)) then
- esat = -999.
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ esat = -999.
+ end select
endif
endif ! (nbad = 0)
+ select type (temp)
+ type is (real(kind=r4_kind))
+ deallocate(esloc_r4, desat_r4, denom_r4)
+ type is (real(kind=r8_kind))
+ deallocate(esloc_r8, desat_r8, denom_r8)
+ end select
end subroutine compute_qs_k_3d
@@ -562,83 +803,319 @@ end subroutine compute_qs_k_3d
subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, &
dqsdT, esat, es_over_liq, es_over_liq_and_ice)
- real, intent(in), dimension(:,:) :: temp, press
- real, intent(in) :: eps, zvir
- real, intent(out), dimension(:,:) :: qs
- integer, intent(out) :: nbad
- real, intent(in), dimension(:,:), optional :: q
- real, intent(in), optional :: hc
- real, intent(out), dimension(:,:), optional :: dqsdT, esat
- logical,intent(in), optional :: es_over_liq
- logical,intent(in), optional :: es_over_liq_and_ice
-
- real, dimension(size(temp,1), size(temp,2)) :: esloc, desat, denom
+ class(*), intent(in), dimension(:,:) :: temp, press
+ real, intent(in) :: eps, zvir
+ class(*), intent(out), dimension(:,:) :: qs
+ integer, intent(out) :: nbad
+ class(*), intent(in), dimension(:,:), optional :: q
+ class(*), intent(in), optional :: hc
+ class(*), intent(out), dimension(:,:), optional :: dqsdT, esat
+ logical,intent(in), optional :: es_over_liq
+ logical,intent(in), optional :: es_over_liq_and_ice
+
+ real(kind=r4_kind), allocatable, dimension(:,:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments
+ real(kind=r8_kind), allocatable, dimension(:,:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments
integer :: i, j
real :: hc_loc
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (press)
+ type is (real(kind=r4_kind))
+ select type (qs)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (press)
+ type is (real(kind=r8_kind))
+ select type (qs)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL)
+ end if
+
+ if (present(q)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (q)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (q)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL)
+ end if
if (present(hc)) then
- hc_loc = hc
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (hc)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (hc)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL)
+ end if
+
+ if (present(dqsdT)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL)
+ end if
+
+ if (present(esat)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ allocate(esloc_r4(size(temp,1), size(temp,2)))
+ allocate(desat_r4(size(temp,1), size(temp,2)))
+ allocate(denom_r4(size(temp,1), size(temp,2)))
+ type is (real(kind=r8_kind))
+ allocate(esloc_r8(size(temp,1), size(temp,2)))
+ allocate(desat_r8(size(temp,1), size(temp,2)))
+ allocate(denom_r8(size(temp,1), size(temp,2)))
+ end select
+
+ if (present(hc)) then
+ select type (hc)
+ type is (real(kind=r4_kind))
+ hc_loc = hc
+ type is (real(kind=r8_kind))
+ hc_loc = real(hc)
+ end select
else
hc_loc = 1.0
endif
- if (present(es_over_liq)) then
- if (present (dqsdT)) then
- call lookup_es2_des2_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
- else
- call lookup_es2_k (temp, esloc, nbad)
- endif
- else if (present(es_over_liq_and_ice)) then
- if (present (dqsdT)) then
- call lookup_es3_des3_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
- else
- call lookup_es3_k (temp, esloc, nbad)
- endif
- else
- if (present (dqsdT)) then
- call lookup_es_des_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
+ if (present(es_over_liq)) then
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es2_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es2_k (temp, esloc_r8, nbad)
+ end select
+ endif
+ else if (present(es_over_liq_and_ice)) then
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es3_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es3_k (temp, esloc_r8, nbad)
+ end select
+ endif
else
- call lookup_es_k (temp, esloc, nbad)
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es_k (temp, esloc_r8, nbad)
+ end select
+ endif
endif
- endif
- esloc = esloc*hc_loc
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ esloc_r8 = esloc_r8*hc_loc
+ end select
+
if (present (esat)) then
- esat = esloc
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = esloc_r4
+ type is (real(kind=r8_kind))
+ esat = esloc_r8
+ end select
endif
+
if (nbad == 0) then
- if (present (q) .and. use_exact_qs) then
- qs = (1.0 + zvir*q)*eps*esloc/press
- if (present (dqsdT)) then
- dqsdT = (1.0 + zvir*q)*eps*desat/press
- endif
- else ! (present(q))
- denom = press - (1.0 - eps)*esloc
- do j=1,size(qs,2)
- do i=1,size(qs,1)
- if (denom(i,j) > 0.0) then
- qs(i,j) = eps*esloc(i,j)/denom(i,j)
- else
- qs(i,j) = eps
- endif
- end do
- end do
- if (present (dqsdT)) then
- dqsdT = eps*press*desat/denom**2
- endif
- endif ! (present(q))
+ select type (press)
+ type is (real(kind=r4_kind))
+ select type (qs)
+ type is (real(kind=r4_kind))
+ if (present (q) .and. use_exact_qs) then
+ select type (q)
+ type is (real(kind=r4_kind))
+ qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press
+ end select
+ endif
+ end select
+ else ! (present(q))
+ denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4
+ do j=1,size(qs,2)
+ do i=1,size(qs,1)
+ if (denom_r4(i,j) > 0.0_r4_kind) then
+ qs(i,j) = real(eps, kind=r4_kind)*esloc_r4(i,j)/denom_r4(i,j)
+ else
+ qs(i,j) = real(eps, kind=r4_kind)
+ endif
+ end do
+ end do
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2
+ end select
+ endif
+ endif ! (present(q))
+ end select
+ type is (real(kind=r8_kind))
+ select type (qs)
+ type is (real(kind=r8_kind))
+ if (present (q) .and. use_exact_qs) then
+ select type (q)
+ type is (real(kind=r8_kind))
+ qs = (1.0 + zvir*q)*eps*esloc_r8/press
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ dqsdT = (1.0 + zvir*q)*eps*desat_r8/press
+ end select
+ endif
+ end select
+ else ! (present(q))
+ denom_r8 = press - (1.0 - eps)*esloc_r8
+ do j=1,size(qs,2)
+ do i=1,size(qs,1)
+ if (denom_r8(i,j) > 0.0) then
+ qs(i,j) = eps*esloc_r8(i,j)/denom_r8(i,j)
+ else
+ qs(i,j) = eps
+ endif
+ end do
+ end do
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ dqsdT = eps*press*desat_r8/denom_r8**2
+ end select
+ endif
+ endif ! (present(q))
+ end select
+ end select
else ! (nbad = 0)
- qs = -999.
+ select type (qs)
+ type is (real(kind=r4_kind))
+ qs = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ qs = -999.
+ end select
if (present (dqsdT)) then
- dqsdT = -999.
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ dqsdT = -999.
+ end select
endif
if (present (esat)) then
- esat = -999.
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ esat = -999.
+ end select
endif
endif ! (nbad = 0)
+ select type (temp)
+ type is (real(kind=r4_kind))
+ deallocate(esloc_r4, desat_r4, denom_r4)
+ type is (real(kind=r8_kind))
+ deallocate(esloc_r8, desat_r8, denom_r8)
+ end select
end subroutine compute_qs_k_2d
@@ -647,81 +1124,315 @@ end subroutine compute_qs_k_2d
subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, &
dqsdT, esat, es_over_liq, es_over_liq_and_ice)
- real, intent(in), dimension(:) :: temp, press
- real, intent(in) :: eps, zvir
- real, intent(out), dimension(:) :: qs
- integer, intent(out) :: nbad
- real, intent(in), dimension(:), optional :: q
- real, intent(in), optional :: hc
- real, intent(out), dimension(:), optional :: dqsdT, esat
- logical,intent(in), optional :: es_over_liq
- logical,intent(in), optional :: es_over_liq_and_ice
-
- real, dimension(size(temp,1)) :: esloc, desat, denom
+ class(*), intent(in), dimension(:) :: temp, press
+ real, intent(in) :: eps, zvir
+ class(*), intent(out),dimension(:) :: qs
+ integer, intent(out) :: nbad
+ class(*), intent(in), dimension(:), optional :: q
+ class(*), intent(in), optional :: hc
+ class(*), intent(out), dimension(:),optional :: dqsdT, esat
+ logical,intent(in), optional :: es_over_liq
+ logical,intent(in), optional :: es_over_liq_and_ice
+
+ real(kind=r4_kind), allocatable, dimension(:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments
+ real(kind=r8_kind), allocatable, dimension(:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments
integer :: i
real :: hc_loc
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (press)
+ type is (real(kind=r4_kind))
+ select type (qs)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (press)
+ type is (real(kind=r8_kind))
+ select type (qs)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL)
+ end if
+
+ if (present(q)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (q)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (q)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL)
+ end if
if (present(hc)) then
- hc_loc = hc
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (hc)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (hc)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL)
+ end if
+
+ if (present(dqsdT)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL)
+ end if
+
+ if (present(esat)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ allocate(esloc_r4(size(temp,1)))
+ allocate(desat_r4(size(temp,1)))
+ allocate(denom_r4(size(temp,1)))
+ type is (real(kind=r8_kind))
+ allocate(esloc_r8(size(temp,1)))
+ allocate(desat_r8(size(temp,1)))
+ allocate(denom_r8(size(temp,1)))
+ end select
+
+ if (present(hc)) then
+ select type (hc)
+ type is (real(kind=r4_kind))
+ hc_loc = hc
+ type is (real(kind=r8_kind))
+ hc_loc = real(hc)
+ end select
else
hc_loc = 1.0
endif
- if (present(es_over_liq)) then
- if (present (dqsdT)) then
- call lookup_es2_des2_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
- else
- call lookup_es2_k (temp, esloc, nbad)
- endif
- else if (present(es_over_liq_and_ice)) then
- if (present (dqsdT)) then
- call lookup_es3_des3_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
- else
- call lookup_es3_k (temp, esloc, nbad)
- endif
- else
- if (present (dqsdT)) then
- call lookup_es_des_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
+ if (present(es_over_liq)) then
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es2_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es2_k (temp, esloc_r8, nbad)
+ end select
+ endif
+ else if (present(es_over_liq_and_ice)) then
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es3_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es3_k (temp, esloc_r8, nbad)
+ end select
+ endif
else
- call lookup_es_k (temp, esloc, nbad)
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es_k (temp, esloc_r8, nbad)
+ end select
+ endif
endif
- endif
- esloc = esloc*hc_loc
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ esloc_r8 = esloc_r8*hc_loc
+ end select
+
if (present (esat)) then
- esat = esloc
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = esloc_r4
+ type is (real(kind=r8_kind))
+ esat = esloc_r8
+ end select
endif
+
if (nbad == 0) then
- if (present (q) .and. use_exact_qs) then
- qs = (1.0 + zvir*q)*eps*esloc/press
- if (present (dqsdT)) then
- dqsdT = (1.0 + zvir*q)*eps*desat/press
- endif
- else ! (present(q))
- denom = press - (1.0 - eps)*esloc
- do i=1,size(qs,1)
- if (denom(i) > 0.0) then
- qs(i) = eps*esloc(i)/denom(i)
- else
- qs(i) = eps
- endif
- end do
- if (present (dqsdT)) then
- dqsdT = eps*press*desat/denom**2
- endif
- endif ! (present(q))
+ select type (press)
+ type is (real(kind=r4_kind))
+ select type (qs)
+ type is (real(kind=r4_kind))
+ if (present (q) .and. use_exact_qs) then
+ select type (q)
+ type is (real(kind=r4_kind))
+ qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press
+ end select
+ endif
+ end select
+ else ! (present(q))
+ denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4
+ do i=1,size(qs,1)
+ if (denom_r4(i) > 0.0_r4_kind) then
+ qs(i) = real(eps, kind=r4_kind)*esloc_r4(i)/denom_r4(i)
+ else
+ qs(i) = real(eps, kind=r4_kind)
+ endif
+ end do
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2
+ end select
+ endif
+ endif ! (present(q))
+ end select
+ type is (real(kind=r8_kind))
+ select type (qs)
+ type is (real(kind=r8_kind))
+ if (present (q) .and. use_exact_qs) then
+ select type (q)
+ type is (real(kind=r8_kind))
+ qs = (1.0 + zvir*q)*eps*esloc_r8/press
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ dqsdT = (1.0 + zvir*q)*eps*desat_r8/press
+ end select
+ endif
+ end select
+ else ! (present(q))
+ denom_r8 = press - (1.0 - eps)*esloc_r8
+ do i=1,size(qs,1)
+ if (denom_r8(i) > 0.0) then
+ qs(i) = eps*esloc_r8(i)/denom_r8(i)
+ else
+ qs(i) = eps
+ endif
+ end do
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ dqsdT = eps*press*desat_r8/denom_r8**2
+ end select
+ endif
+ endif ! (present(q))
+ end select
+ end select
else ! (nbad = 0)
- qs = -999.
+ select type (qs)
+ type is (real(kind=r4_kind))
+ qs = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ qs = -999.
+ end select
if (present (dqsdT)) then
- dqsdT = -999.
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ dqsdT = -999.
+ end select
endif
if (present (esat)) then
- esat = -999.
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ esat = -999.
+ end select
endif
endif ! (nbad = 0)
+ select type (temp)
+ type is (real(kind=r4_kind))
+ deallocate(esloc_r4, desat_r4, denom_r4)
+ type is (real(kind=r8_kind))
+ deallocate(esloc_r8, desat_r8, denom_r8)
+ end select
end subroutine compute_qs_k_1d
@@ -730,79 +1441,293 @@ end subroutine compute_qs_k_1d
subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, &
dqsdT, esat, es_over_liq, es_over_liq_and_ice)
- real, intent(in) :: temp, press
+ class(*), intent(in) :: temp, press
real, intent(in) :: eps, zvir
- real, intent(out) :: qs
+ class(*), intent(out) :: qs
integer, intent(out) :: nbad
- real, intent(in), optional :: q
- real, intent(in), optional :: hc
- real, intent(out), optional :: dqsdT, esat
+ class(*), intent(in), optional :: q
+ class(*), intent(in), optional :: hc
+ class(*), intent(out), optional :: dqsdT, esat
logical,intent(in), optional :: es_over_liq
- logical,intent(in), optional :: es_over_liq_and_ice
+ logical,intent(in), optional :: es_over_liq_and_ice
- real :: esloc, desat, denom
+ real(kind=r4_kind) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments
+ real(kind=r8_kind) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments
real :: hc_loc
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (press)
+ type is (real(kind=r4_kind))
+ select type (qs)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (press)
+ type is (real(kind=r8_kind))
+ select type (qs)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL)
+ end if
+
+ if (present(q)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (q)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (q)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL)
+ end if
if (present(hc)) then
- hc_loc = hc
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (hc)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (hc)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL)
+ end if
+
+ if (present(dqsdT)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL)
+ end if
+
+ if (present(esat)) then
+ valid_types = .false.
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end if
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
+
+ if (present(hc)) then
+ select type (hc)
+ type is (real(kind=r4_kind))
+ hc_loc = hc
+ type is (real(kind=r8_kind))
+ hc_loc = real(hc)
+ end select
else
hc_loc = 1.0
endif
- if (present(es_over_liq)) then
- if (present (dqsdT)) then
- call lookup_es2_des2_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
- else
- call lookup_es2_k (temp, esloc, nbad)
- endif
- else if (present(es_over_liq_and_ice)) then
- if (present (dqsdT)) then
- call lookup_es3_des3_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
- else
- call lookup_es3_k (temp, esloc, nbad)
- endif
- else
- if (present (dqsdT)) then
- call lookup_es_des_k (temp, esloc, desat, nbad)
- desat = desat*hc_loc
+ if (present(es_over_liq)) then
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es2_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es2_k (temp, esloc_r8, nbad)
+ end select
+ endif
+ else if (present(es_over_liq_and_ice)) then
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es3_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es3_k (temp, esloc_r8, nbad)
+ end select
+ endif
else
- call lookup_es_k (temp, esloc, nbad)
+ if (present (dqsdT)) then
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad)
+ desat_r4 = desat_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad)
+ desat_r8 = desat_r8*hc_loc
+ end select
+ else
+ select type (temp)
+ type is (real(kind=r4_kind))
+ call lookup_es_k (temp, esloc_r4, nbad)
+ type is (real(kind=r8_kind))
+ call lookup_es_k (temp, esloc_r8, nbad)
+ end select
+ endif
endif
- endif
- esloc = esloc*hc_loc
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind)
+ type is (real(kind=r8_kind))
+ esloc_r8 = esloc_r8*hc_loc
+ end select
+
if (present (esat)) then
- esat = esloc
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = esloc_r4
+ type is (real(kind=r8_kind))
+ esat = esloc_r8
+ end select
endif
+
if (nbad == 0) then
- if (present (q) .and. use_exact_qs) then
- qs = (1.0 + zvir*q)*eps*esloc/press
- if (present (dqsdT)) then
- dqsdT = (1.0 + zvir*q)*eps*desat/press
- endif
- else ! (present(q))
- denom = press - (1.0 - eps)*esloc
- if (denom > 0.0) then
- qs = eps*esloc/denom
- else
- qs = eps
- endif
- if (present (dqsdT)) then
- dqsdT = eps*press*desat/denom**2
- endif
- endif ! (present(q))
+ select type (press)
+ type is (real(kind=r4_kind))
+ select type (qs)
+ type is (real(kind=r4_kind))
+ if (present (q) .and. use_exact_qs) then
+ select type (q)
+ type is (real(kind=r4_kind))
+ qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press
+ end select
+ endif
+ end select
+ else ! (present(q))
+ denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4
+ if (denom_r4 > 0.0_r4_kind) then
+ qs = real(eps, kind=r4_kind)*esloc_r4/denom_r4
+ else
+ qs = real(eps, kind=r4_kind)
+ endif
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2
+ end select
+ endif
+ endif ! (present(q))
+ end select
+ type is (real(kind=r8_kind))
+ select type (qs)
+ type is (real(kind=r8_kind))
+ if (present (q) .and. use_exact_qs) then
+ select type (q)
+ type is (real(kind=r8_kind))
+ qs = (1.0 + zvir*q)*eps*esloc_r8/press
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ dqsdT = (1.0 + zvir*q)*eps*desat_r8/press
+ end select
+ endif
+ end select
+ else ! (present(q))
+ denom_r8 = press - (1.0 - eps)*esloc_r8
+ if (denom_r8 > 0.0) then
+ qs = eps*esloc_r8/denom_r8
+ else
+ qs = eps
+ endif
+ if (present (dqsdT)) then
+ select type (dqsdT)
+ type is (real(kind=r8_kind))
+ dqsdT = eps*press*desat_r8/denom_r8**2
+ end select
+ endif
+ endif ! (present(q))
+ end select
+ end select
else ! (nbad = 0)
- qs = -999.
+ select type (qs)
+ type is (real(kind=r4_kind))
+ qs = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ qs = -999.
+ end select
if (present (dqsdT)) then
- dqsdT = -999.
+ select type (dqsdT)
+ type is (real(kind=r4_kind))
+ dqsdT = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ dqsdT = -999.
+ end select
endif
if (present (esat)) then
- esat = -999.
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = -999.0_r4_kind
+ type is (real(kind=r8_kind))
+ esat = -999.
+ end select
endif
endif ! (nbad = 0)
-
end subroutine compute_qs_k_0d
!#######################################################################
@@ -1148,107 +2073,292 @@ end subroutine compute_mrs_k_0d
!#######################################################################
subroutine lookup_es_des_k_3d (temp, esat, desat, nbad)
- real, intent(in), dimension(:,:,:) :: temp
- real, intent(out), dimension(:,:,:) :: esat, desat
+ class(*), intent(in), dimension(:,:,:) :: temp
+ class(*), intent(out), dimension(:,:,:) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j, k
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_3d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL)
+ end if
nbad = 0
- do k = 1, size(temp,3)
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j,k)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j,k) = TABLE(ind+1) + &
- del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
- desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
- endif
- enddo
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j,k)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind)
+ desat(i,j,k) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j,k))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1))
+ desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
+ end select
end subroutine lookup_es_des_k_3d
!#######################################################################
subroutine lookup_es_des_k_2d (temp, esat, desat, nbad)
- real, intent(in), dimension(:,:) :: temp
- real, intent(out), dimension(:,:) :: esat, desat
+ class(*), intent(in), dimension(:,:) :: temp
+ class(*), intent(out), dimension(:,:) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_2d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL)
+ end if
nbad = 0
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j) = TABLE(ind+1) + &
- del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
- desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
- endif
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind)
+ desat(i,j) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1))
+ desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
+ endif
+ enddo
+ enddo
+ end select
+ end select
+ end select
end subroutine lookup_es_des_k_2d
!#######################################################################
subroutine lookup_es_des_k_1d (temp, esat, desat, nbad)
- real, intent(in), dimension(:) :: temp
- real, intent(out), dimension(:) :: esat, desat
+ class(*), intent(in), dimension(:) :: temp
+ class(*), intent(out), dimension(:) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_1d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL)
+ end if
nbad = 0
- do i = 1, size(temp,1)
- tmp = temp(i)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i) = TABLE(ind+1) + &
- del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
- desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
- endif
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do i = 1, size(temp,1)
+ tmp = temp(i)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind)
+ desat(i) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do i = 1, size(temp,1)
+ tmp = real(temp(i))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1))
+ desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
+ endif
+ enddo
+ end select
+ end select
+ end select
end subroutine lookup_es_des_k_1d
!#######################################################################
subroutine lookup_es_des_k_0d (temp, esat, desat, nbad)
- real, intent(in) :: temp
- real, intent(out) :: esat, desat
+ class(*), intent(in) :: temp
+ class(*), intent(out) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
- tmp = temp-tminl
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ tmp = temp-tminl
+ type is (real(kind=r8_kind))
+ tmp = real(temp)-tminl
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- esat = TABLE(ind+1) + &
- del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
- desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ esat = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1))
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',&
+ & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
+ select type (desat)
+ type is (real(kind=r4_kind))
+ desat = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',&
+ & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
endif
end subroutine lookup_es_des_k_0d
@@ -1256,289 +2366,754 @@ end subroutine lookup_es_des_k_0d
!#######################################################################
subroutine lookup_es_k_3d(temp, esat, nbad)
- real, intent(in), dimension(:,:,:) :: temp
- real, intent(out), dimension(:,:,:) :: esat
+ class(*), intent(in), dimension(:,:,:) :: temp
+ class(*), intent(out), dimension(:,:,:) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j, k
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_k_3d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
nbad = 0
- do k = 1, size(temp,3)
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j,k)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j,k) = TABLE(ind+1) + &
- del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
- endif
- enddo
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j,k)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j,k))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1))
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_es_k_3d
!#######################################################################
subroutine lookup_des_k_3d(temp, desat, nbad)
- real, intent(in), dimension(:,:,:) :: temp
- real, intent(out), dimension(:,:,:) :: desat
+ class(*), intent(in), dimension(:,:,:) :: temp
+ class(*), intent(out), dimension(:,:,:) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j, k
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_3d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL)
+ end if
nbad = 0
- do k = 1, size(temp,3)
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j,k)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
- endif
- enddo
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j,k)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j,k) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j,k))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_des_k_3d
!#######################################################################
subroutine lookup_des_k_2d(temp, desat, nbad)
- real, intent(in), dimension(:,:) :: temp
- real, intent(out), dimension(:,:) :: desat
+ class(*), intent(in), dimension(:,:) :: temp
+ class(*), intent(out), dimension(:,:) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_2d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL)
+ end if
nbad = 0
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
- endif
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
+ endif
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_des_k_2d
!#######################################################################
subroutine lookup_es_k_2d(temp, esat, nbad)
- real, intent(in), dimension(:,:) :: temp
- real, intent(out), dimension(:,:) :: esat
+ class(*), intent(in), dimension(:,:) :: temp
+ class(*), intent(out), dimension(:,:) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_k_2d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
nbad = 0
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j) = TABLE(ind+1) + del*(DTABLE(ind+1) + &
- del*D2TABLE(ind+1))
- endif
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1))
+ endif
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_es_k_2d
!#######################################################################
subroutine lookup_des_k_1d(temp, desat, nbad)
- real, intent(in), dimension(:) :: temp
- real, intent(out), dimension(:) :: desat
+ class(*), intent(in), dimension(:) :: temp
+ class(*), intent(out), dimension(:) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_1d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL)
+ end if
nbad = 0
- do i = 1, size(temp,1)
- tmp = temp(i)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
- endif
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do i = 1, size(temp,1)
+ tmp = temp(i)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do i = 1, size(temp,1)
+ tmp = real(temp(i))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
+ endif
+ enddo
+ end select
+ end select
end subroutine lookup_des_k_1d
!#######################################################################
subroutine lookup_es_k_1d(temp, esat, nbad)
- real, intent(in), dimension(:) :: temp
- real, intent(out), dimension(:) :: esat
+ class(*), intent(in), dimension(:) :: temp
+ class(*), intent(out), dimension(:) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_k_1d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
nbad = 0
- do i = 1, size(temp,1)
- tmp = temp(i)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
- endif
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ do i = 1, size(temp,1)
+ tmp = temp(i)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = real(( TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) ), kind=r4_kind)
+ endif
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ do i = 1, size(temp,1)
+ tmp = real(temp(i))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
+ endif
+ enddo
+ end select
+ end select
end subroutine lookup_es_k_1d
!#######################################################################
subroutine lookup_des_k_0d(temp, desat, nbad)
- real, intent(in) :: temp
- real, intent(out) :: desat
+ class(*), intent(in) :: temp
+ class(*), intent(out) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
- tmp = temp-tminl
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ tmp = temp-tminl
+ type is (real(kind=r8_kind))
+ tmp = real(temp)-tminl
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
+ select type (desat)
+ type is (real(kind=r4_kind))
+ desat = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',&
+ & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
endif
end subroutine lookup_des_k_0d
!#######################################################################
subroutine lookup_es_k_0d(temp, esat, nbad)
- real, intent(in) :: temp
- real, intent(out) :: esat
+ class(*), intent(in) :: temp
+ class(*), intent(out) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
- tmp = temp-tminl
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ tmp = temp-tminl
+ type is (real(kind=r8_kind))
+ tmp = real(temp)-tminl
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = real(( TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) ), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',&
+ & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
endif
end subroutine lookup_es_k_0d
!#######################################################################
subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad)
- real, intent(in), dimension(:,:,:) :: temp
- real, intent(out), dimension(:,:,:) :: esat, desat
+ class(*), intent(in), dimension(:,:,:) :: temp
+ class(*), intent(out), dimension(:,:,:) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j, k
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_3d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL)
+ end if
nbad = 0
- do k = 1, size(temp,3)
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j,k)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j,k) = TABLE2(ind+1) + &
- del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
- desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
- endif
- enddo
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j,k)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind)
+ desat(i,j,k) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j,k))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1))
+ desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
+ end select
end subroutine lookup_es2_des2_k_3d
!#######################################################################
subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad)
- real, intent(in), dimension(:,:) :: temp
- real, intent(out), dimension(:,:) :: esat, desat
+ class(*), intent(in), dimension(:,:) :: temp
+ class(*), intent(out), dimension(:,:) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_2d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL)
+ end if
nbad = 0
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j) = TABLE2(ind+1) + &
- del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
- desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
- endif
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind)
+ desat(i,j) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1))
+ desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
+ endif
+ enddo
+ enddo
+ end select
+ end select
+ end select
end subroutine lookup_es2_des2_k_2d
!#######################################################################
subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad)
- real, intent(in), dimension(:) :: temp
- real, intent(out), dimension(:) :: esat, desat
+ class(*), intent(in), dimension(:) :: temp
+ class(*), intent(out), dimension(:) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_1d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL)
+ end if
nbad = 0
- do i = 1, size(temp,1)
- tmp = temp(i)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i) = TABLE2(ind+1) + &
- del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
- desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
- endif
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do i = 1, size(temp,1)
+ tmp = temp(i)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind)
+ desat(i) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do i = 1, size(temp,1)
+ tmp = real(temp(i))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1))
+ desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
+ endif
+ enddo
+ end select
+ end select
+ end select
end subroutine lookup_es2_des2_k_1d
!#######################################################################
subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad)
- real, intent(in) :: temp
- real, intent(out) :: esat, desat
+ class(*), intent(in) :: temp
+ class(*), intent(out) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
- tmp = temp-tminl
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ tmp = temp-tminl
+ type is (real(kind=r8_kind))
+ tmp = real(temp)-tminl
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- esat = TABLE2(ind+1) + &
- del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
- desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ esat = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1))
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',&
+ & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
+ select type (desat)
+ type is (real(kind=r4_kind))
+ desat = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',&
+ & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
endif
end subroutine lookup_es2_des2_k_0d
@@ -1546,182 +3121,462 @@ end subroutine lookup_es2_des2_k_0d
!#######################################################################
subroutine lookup_es2_k_3d(temp, esat, nbad)
- real, intent(in), dimension(:,:,:) :: temp
- real, intent(out), dimension(:,:,:) :: esat
+ class(*), intent(in), dimension(:,:,:) :: temp
+ class(*), intent(out), dimension(:,:,:) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j, k
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_3d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
nbad = 0
- do k = 1, size(temp,3)
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j,k)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j,k) = TABLE2(ind+1) + &
- del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
- endif
- enddo
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j,k)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = real(( TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j,k))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1))
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_es2_k_3d
!#######################################################################
subroutine lookup_des2_k_3d(temp, desat, nbad)
- real, intent(in), dimension(:,:,:) :: temp
- real, intent(out), dimension(:,:,:) :: desat
+ class(*), intent(in), dimension(:,:,:) :: temp
+ class(*), intent(out), dimension(:,:,:) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j, k
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_3d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL)
+ end if
nbad = 0
- do k = 1, size(temp,3)
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j,k)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
- endif
- enddo
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j,k)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j,k) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j,k))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_des2_k_3d
!#######################################################################
subroutine lookup_des2_k_2d(temp, desat, nbad)
- real, intent(in), dimension(:,:) :: temp
- real, intent(out), dimension(:,:) :: desat
+ class(*), intent(in), dimension(:,:) :: temp
+ class(*), intent(out), dimension(:,:) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_2d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL)
+ end if
nbad = 0
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
- endif
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
+ endif
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_des2_k_2d
!#######################################################################
subroutine lookup_es2_k_2d(temp, esat, nbad)
- real, intent(in), dimension(:,:) :: temp
- real, intent(out), dimension(:,:) :: esat
+ class(*), intent(in), dimension(:,:) :: temp
+ class(*), intent(out), dimension(:,:) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_2d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
nbad = 0
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j) = TABLE2(ind+1) + del*(DTABLE2(ind+1) + &
- del*D2TABLE2(ind+1))
- endif
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = real(( TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1))
+ endif
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_es2_k_2d
!#######################################################################
subroutine lookup_des2_k_1d(temp, desat, nbad)
- real, intent(in), dimension(:) :: temp
- real, intent(out), dimension(:) :: desat
+ class(*), intent(in), dimension(:) :: temp
+ class(*), intent(out), dimension(:) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_1d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL)
+ end if
nbad = 0
- do i = 1, size(temp,1)
- tmp = temp(i)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
- endif
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do i = 1, size(temp,1)
+ tmp = temp(i)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do i = 1, size(temp,1)
+ tmp = real(temp(i))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
+ endif
+ enddo
+ end select
+ end select
end subroutine lookup_des2_k_1d
!#######################################################################
subroutine lookup_es2_k_1d(temp, esat, nbad)
- real, intent(in), dimension(:) :: temp
- real, intent(out), dimension(:) :: esat
+ class(*), intent(in), dimension(:) :: temp
+ class(*), intent(out), dimension(:) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_1d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
nbad = 0
- do i = 1, size(temp,1)
- tmp = temp(i)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
- endif
- enddo
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ do i = 1, size(temp,1)
+ tmp = temp(i)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) ), kind=r4_kind)
+ endif
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ do i = 1, size(temp,1)
+ tmp = real(temp(i))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
+ endif
+ enddo
+ end select
+ end select
+
end subroutine lookup_es2_k_1d
!#######################################################################
subroutine lookup_des2_k_0d(temp, desat, nbad)
- real, intent(in) :: temp
- real, intent(out) :: desat
+ class(*), intent(in) :: temp
+ class(*), intent(out) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
- tmp = temp-tminl
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ tmp = temp-tminl
+ type is (real(kind=r8_kind))
+ tmp = real(temp)-tminl
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
+ select type (desat)
+ type is (real(kind=r4_kind))
+ desat = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',&
+ & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
endif
end subroutine lookup_des2_k_0d
!#######################################################################
subroutine lookup_es2_k_0d(temp, esat, nbad)
- real, intent(in) :: temp
- real, intent(out) :: esat
+ class(*), intent(in) :: temp
+ class(*), intent(out) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
- tmp = temp-tminl
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ tmp = temp-tminl
+ type is (real(kind=r8_kind))
+ tmp = real(temp)-tminl
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',&
+ & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
endif
end subroutine lookup_es2_k_0d
@@ -1730,107 +3585,292 @@ end subroutine lookup_es2_k_0d
!#######################################################################
subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad)
- real, intent(in), dimension(:,:,:) :: temp
- real, intent(out), dimension(:,:,:) :: esat, desat
+ class(*), intent(in), dimension(:,:,:) :: temp
+ class(*), intent(out), dimension(:,:,:) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j, k
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_3d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL)
+ end if
nbad = 0
- do k = 1, size(temp,3)
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j,k)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j,k) = TABLE3(ind+1) + &
- del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
- desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
- endif
- enddo
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j,k)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind)
+ desat(i,j,k) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j,k))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1))
+ desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
+ end select
end subroutine lookup_es3_des3_k_3d
!#######################################################################
subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad)
- real, intent(in), dimension(:,:) :: temp
- real, intent(out), dimension(:,:) :: esat, desat
+ class(*), intent(in), dimension(:,:) :: temp
+ class(*), intent(out), dimension(:,:) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_2d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL)
+ end if
nbad = 0
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j) = TABLE3(ind+1) + &
- del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
- desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
- endif
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind)
+ desat(i,j) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1))
+ desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
+ endif
+ enddo
+ enddo
+ end select
+ end select
+ end select
end subroutine lookup_es3_des3_k_2d
!#######################################################################
subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad)
- real, intent(in), dimension(:) :: temp
- real, intent(out), dimension(:) :: esat, desat
+ class(*), intent(in), dimension(:) :: temp
+ class(*), intent(out), dimension(:) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_1d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL)
+ end if
nbad = 0
- do i = 1, size(temp,1)
- tmp = temp(i)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i) = TABLE3(ind+1) + &
- del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
- desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
- endif
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do i = 1, size(temp,1)
+ tmp = temp(i)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind)
+ desat(i) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ end select
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do i = 1, size(temp,1)
+ tmp = real(temp(i))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1))
+ desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
+ endif
+ enddo
+ end select
+ end select
+ end select
end subroutine lookup_es3_des3_k_1d
!#######################################################################
subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad)
- real, intent(in) :: temp
- real, intent(out) :: esat, desat
+ class(*), intent(in) :: temp
+ class(*), intent(out) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
- tmp = temp-tminl
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ tmp = temp-tminl
+ type is (real(kind=r8_kind))
+ tmp = real(temp)-tminl
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- esat = TABLE3(ind+1) + &
- del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
- desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ esat = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1))
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',&
+ & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
+ select type (desat)
+ type is (real(kind=r4_kind))
+ desat = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',&
+ & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
endif
end subroutine lookup_es3_des3_k_0d
@@ -1838,182 +3878,462 @@ end subroutine lookup_es3_des3_k_0d
!#######################################################################
subroutine lookup_es3_k_3d(temp, esat, nbad)
- real, intent(in), dimension(:,:,:) :: temp
- real, intent(out), dimension(:,:,:) :: esat
+ class(*), intent(in), dimension(:,:,:) :: temp
+ class(*), intent(out), dimension(:,:,:) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j, k
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_3d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
nbad = 0
- do k = 1, size(temp,3)
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j,k)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j,k) = TABLE3(ind+1) + &
- del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
- endif
- enddo
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j,k)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = real(( TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j,k))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j,k) = TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1))
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_es3_k_3d
!#######################################################################
subroutine lookup_des3_k_3d(temp, desat, nbad)
- real, intent(in), dimension(:,:,:) :: temp
- real, intent(out), dimension(:,:,:) :: desat
+ class(*), intent(in), dimension(:,:,:) :: temp
+ class(*), intent(out), dimension(:,:,:) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j, k
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_3d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL)
+ end if
nbad = 0
- do k = 1, size(temp,3)
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j,k)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
- endif
- enddo
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j,k)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j,k) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do k = 1, size(temp,3)
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j,k))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
+ endif
+ enddo
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_des3_k_3d
!#######################################################################
subroutine lookup_des3_k_2d(temp, desat, nbad)
- real, intent(in), dimension(:,:) :: temp
- real, intent(out), dimension(:,:) :: desat
+ class(*), intent(in), dimension(:,:) :: temp
+ class(*), intent(out), dimension(:,:) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_2d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL)
+ end if
nbad = 0
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
- endif
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
+ endif
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_des3_k_2d
!#######################################################################
subroutine lookup_es3_k_2d(temp, esat, nbad)
- real, intent(in), dimension(:,:) :: temp
- real, intent(out), dimension(:,:) :: esat
+ class(*), intent(in), dimension(:,:) :: temp
+ class(*), intent(out), dimension(:,:) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i, j
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_2d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
nbad = 0
- do j = 1, size(temp,2)
- do i = 1, size(temp,1)
- tmp = temp(i,j)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i,j) = TABLE3(ind+1) + del*(DTABLE3(ind+1) + &
- del*D2TABLE3(ind+1))
- endif
- enddo
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = temp(i,j)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = real(( TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind)
+ endif
+ enddo
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ do j = 1, size(temp,2)
+ do i = 1, size(temp,1)
+ tmp = real(temp(i,j))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i,j) = TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1))
+ endif
+ enddo
+ enddo
+ end select
+ end select
end subroutine lookup_es3_k_2d
!#######################################################################
subroutine lookup_des3_k_1d(temp, desat, nbad)
- real, intent(in), dimension(:) :: temp
- real, intent(out), dimension(:) :: desat
+ class(*), intent(in), dimension(:) :: temp
+ class(*), intent(out), dimension(:) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_1d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL)
+ end if
nbad = 0
- do i = 1, size(temp,1)
- tmp = temp(i)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
- endif
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (desat)
+ type is (real(kind=r4_kind))
+ do i = 1, size(temp,1)
+ tmp = temp(i)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind)
+ endif
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (desat)
+ type is (real(kind=r8_kind))
+ do i = 1, size(temp,1)
+ tmp = real(temp(i))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
+ endif
+ enddo
+ end select
+ end select
end subroutine lookup_des3_k_1d
!#######################################################################
subroutine lookup_es3_k_1d(temp, esat, nbad)
- real, intent(in), dimension(:) :: temp
- real, intent(out), dimension(:) :: esat
+ class(*), intent(in), dimension(:) :: temp
+ class(*), intent(out), dimension(:) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind, i
+ logical :: valid_types = .false. !< For checking if variable types match
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ valid_types = .true.
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ valid_types = .true.
+ end select
+ end select
+ if ( .not. valid_types ) then
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_1d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL)
+ end if
nbad = 0
- do i = 1, size(temp,1)
- tmp = temp(i)-tminl
- ind = int(dtinvl*(tmp+tepsl))
- if (ind < 0 .or. ind >= table_siz) then
- nbad = nbad+1
- else
- del = tmp-dtres*real(ind)
- esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
- endif
- enddo
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ do i = 1, size(temp,1)
+ tmp = temp(i)-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) ), kind=r4_kind)
+ endif
+ enddo
+ end select
+ type is (real(kind=r8_kind))
+ select type (esat)
+ type is (real(kind=r8_kind))
+ do i = 1, size(temp,1)
+ tmp = real(temp(i))-tminl
+ ind = int(dtinvl*(tmp+tepsl))
+ if (ind < 0 .or. ind >= table_siz) then
+ nbad = nbad+1
+ else
+ del = tmp-dtres*real(ind)
+ esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
+ endif
+ enddo
+ end select
+ end select
end subroutine lookup_es3_k_1d
!#######################################################################
subroutine lookup_des3_k_0d(temp, desat, nbad)
- real, intent(in) :: temp
- real, intent(out) :: desat
+ class(*), intent(in) :: temp
+ class(*), intent(out) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
- tmp = temp-tminl
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ tmp = temp-tminl
+ type is (real(kind=r8_kind))
+ tmp = real(temp)-tminl
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
+ select type (desat)
+ type is (real(kind=r4_kind))
+ desat = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',&
+ & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
endif
end subroutine lookup_des3_k_0d
!#######################################################################
subroutine lookup_es3_k_0d(temp, esat, nbad)
- real, intent(in) :: temp
- real, intent(out) :: esat
+ class(*), intent(in) :: temp
+ class(*), intent(out) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
- tmp = temp-tminl
+
+ select type (temp)
+ type is (real(kind=r4_kind))
+ tmp = temp-tminl
+ type is (real(kind=r8_kind))
+ tmp = real(temp)-tminl
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',&
+ & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
+ select type (esat)
+ type is (real(kind=r4_kind))
+ esat = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))), kind=r4_kind)
+ type is (real(kind=r8_kind))
+ esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
+ class default
+ call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',&
+ & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
endif
end subroutine lookup_es3_k_0d
diff --git a/time_manager/time_manager.F90 b/time_manager/time_manager.F90
index 312e31006c..2f6e4fcfa6 100644
--- a/time_manager/time_manager.F90
+++ b/time_manager/time_manager.F90
@@ -87,7 +87,7 @@
module time_manager_mod
-use platform_mod, only: r8_kind
+use platform_mod, only: r4_kind, r8_kind
use constants_mod, only: rseconds_per_day=>seconds_per_day
use fms_mod, only: error_mesg, FATAL, WARNING, write_version_number, stdout
@@ -1202,7 +1202,7 @@ end function time_type_to_real
!! @return A filled time type variable, and an error message if an
!! error occurs.
function real_to_time_type(x,err_msg) result(t)
- real,intent(in) :: x !< Number of seconds.
+ class(*),intent(in) :: x !< Number of seconds.
character(len=*),intent(out),optional :: err_msg !< Error message.
type(time_type) :: t
integer :: days
@@ -1213,9 +1213,29 @@ function real_to_time_type(x,err_msg) result(t)
real :: tps
real :: a
tps = real(ticks_per_second)
- a = x/spd
+
+ select type (x)
+ type is (real(kind=r4_kind))
+ a = x/spd
+ type is (real(kind=r8_kind))
+ a = real(x)/spd
+ class default
+ call error_mesg('time_manager_mod::real_to_time_type',&
+ & 'x is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
days = safe_rtoi(a,do_floor)
- a = x - real(days)*spd
+
+ select type (x)
+ type is (real(kind=r4_kind))
+ a = x - real(days)*spd
+ type is (real(kind=r8_kind))
+ a = real(x) - real(days)*spd
+ class default
+ call error_mesg('time_manager_mod::real_to_time_type',&
+ & 'x is not one of the supported types of real(kind=4) or real(kind=8)', FATAL)
+ end select
+
seconds = safe_rtoi(a,do_floor)
a = (a - real(seconds))*tps
ticks = safe_rtoi(a,do_nearest)
diff --git a/tracer_manager/tracer_manager.F90 b/tracer_manager/tracer_manager.F90
index 6add5c33e9..bb683a17b8 100644
--- a/tracer_manager/tracer_manager.F90
+++ b/tracer_manager/tracer_manager.F90
@@ -76,6 +76,8 @@ module tracer_manager_mod
fm_exists, &
MODEL_NAMES
+use platform_mod, only: r4_kind, r8_kind
+
implicit none
private
@@ -1034,7 +1036,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg)
integer, intent(in) :: model !< Parameter representing component model in use
integer, intent(in) :: n !< Tracer number
-real, intent(inout), dimension(:,:,:) :: tracer !< Initialized tracer array
+class(*), intent(inout), dimension(:,:,:) :: tracer !< Initialized tracer array
character(len=*), intent(out), optional :: err_msg
real :: surf_value, multiplier
@@ -1060,7 +1062,14 @@ subroutine set_tracer_profile(model, n, tracer, err_msg)
bottom_value = surf_value
multiplier = 1.0
-tracer = surf_value
+select type (tracer)
+type is (real(kind=r4_kind))
+ tracer = surf_value
+type is (real(kind=r8_kind))
+ tracer = surf_value
+class default
+ call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)")
+end select
if ( query_method ( 'profile_type',model,n,scheme,control)) then
!Change the tracer_number to the tracer_manager version
@@ -1069,7 +1078,14 @@ subroutine set_tracer_profile(model, n, tracer, err_msg)
profile_type = 'Fixed'
flag =parse(control,'surface_value',surf_value)
multiplier = 1.0
- tracer = surf_value
+ select type (tracer)
+ type is (real(kind=r4_kind))
+ tracer = surf_value
+ type is (real(kind=r8_kind))
+ tracer = surf_value
+ class default
+ call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)")
+ end select
endif
if(lowercase(trim(scheme(1:7))).eq.'profile') then
@@ -1102,16 +1118,36 @@ subroutine set_tracer_profile(model, n, tracer, err_msg)
select case (tracers(n1)%model)
case (MODEL_ATMOS)
multiplier = exp( log (top_value/surf_value) /numlevels)
- tracer(:,:,1) = surf_value
- do k = 2, size(tracer,3)
- tracer(:,:,k) = tracer(:,:,k-1) * multiplier
- enddo
+ select type (tracer)
+ type is (real(kind=r4_kind))
+ tracer(:,:,1) = surf_value
+ do k = 2, size(tracer,3)
+ tracer(:,:,k) = tracer(:,:,k-1) * multiplier
+ enddo
+ type is (real(kind=r8_kind))
+ tracer(:,:,1) = surf_value
+ do k = 2, size(tracer,3)
+ tracer(:,:,k) = tracer(:,:,k-1) * multiplier
+ enddo
+ class default
+ call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)")
+ end select
case (MODEL_OCEAN)
multiplier = exp( log (bottom_value/surf_value) /numlevels)
- tracer(:,:,size(tracer,3)) = surf_value
- do k = size(tracer,3) - 1, 1, -1
- tracer(:,:,k) = tracer(:,:,k+1) * multiplier
- enddo
+ select type (tracer)
+ type is (real(kind=r4_kind))
+ tracer(:,:,size(tracer,3)) = surf_value
+ do k = size(tracer,3) - 1, 1, -1
+ tracer(:,:,k) = tracer(:,:,k+1) * multiplier
+ enddo
+ type is (real(kind=r8_kind))
+ tracer(:,:,size(tracer,3)) = surf_value
+ do k = size(tracer,3) - 1, 1, -1
+ tracer(:,:,k) = tracer(:,:,k+1) * multiplier
+ enddo
+ class default
+ call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)")
+ end select
case default
end select
endif !scheme.eq.profile