From e23cd38379c5df3686bd9e33b0466d94a158ca35 Mon Sep 17 00:00:00 2001
From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com>
Date: Mon, 14 Feb 2022 14:43:14 -0500
Subject: [PATCH] Revert "feat: emc changes for mixedmode (#857) (#898)"
This reverts commit 516a5efa681e5ae954c11c0c90677b4444e28ec4.
---
CMakeLists.txt | 2 -
constants4/constants4.F90 | 176 --
constants4/fmsconstants4.F90 | 32 -
diag_manager/diag_axis.F90 | 24 +-
diag_manager/diag_grid.F90 | 73 +-
diag_manager/diag_manager.F90 | 688 +++--
diag_manager/diag_util.F90 | 38 +-
sat_vapor_pres/sat_vapor_pres.F90 | 272 +-
sat_vapor_pres/sat_vapor_pres_k.F90 | 3648 +++++----------------------
time_manager/time_manager.F90 | 28 +-
tracer_manager/tracer_manager.F90 | 58 +-
11 files changed, 1095 insertions(+), 3944 deletions(-)
delete mode 100644 constants4/constants4.F90
delete mode 100644 constants4/fmsconstants4.F90
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 31710aa7a7..524307c7dc 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -100,8 +100,6 @@ 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
deleted file mode 100644
index c244b6a428..0000000000
--- a/constants4/constants4.F90
+++ /dev/null
@@ -1,176 +0,0 @@
-!***********************************************************************
-!* 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
deleted file mode 100644
index 5d7af83dbc..0000000000
--- a/constants4/fmsconstants4.F90
+++ /dev/null
@@ -1,32 +0,0 @@
-!***********************************************************************
-!* 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 8f19ed865b..faf1c4909a 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
- CLASS(*), DIMENSION(:), INTENT(in) :: DATA !< Array of coordinate values
+ REAL, 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,15 +231,7 @@ 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)
- 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)%data = DATA(1:axlen)
Axes(diag_axis_init)%units = units
Axes(diag_axis_init)%length = axlen
Axes(diag_axis_init)%set = set
@@ -468,7 +460,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".
- CLASS(*), DIMENSION(:), INTENT(out) :: DATA !< Array of coordinate values for this axis.
+ REAL, 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
@@ -489,15 +481,7 @@ 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
- 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
+ DATA(1:Axes(id)%length) = Axes(id)%data(1:Axes(id)%length)
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 12b9c9115f..d394332cfe 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.
- 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.
+ 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.
INTEGER, DIMENSION(1) :: tile
INTEGER :: ntiles
@@ -254,67 +254,14 @@ 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
- 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
+ diag_global_grid%aglo_lat = TRANSPOSE(aglo_lat)
+ diag_global_grid%aglo_lon = TRANSPOSE(aglo_lon)
ELSE
- 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
+ diag_global_grid%aglo_lat = aglo_lat
+ diag_global_grid%aglo_lon = aglo_lon
END IF
-
- 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%glo_lat = glo_lat
+ diag_global_grid%glo_lon = glo_lon
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 a38777e4f2..08933eaa10 100644
--- a/diag_manager/diag_manager.F90
+++ b/diag_manager/diag_manager.F90
@@ -329,6 +329,12 @@ 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
@@ -368,8 +374,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
- CLASS(*), OPTIONAL, INTENT(in) :: missing_value
- CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range
+ REAL, OPTIONAL, INTENT(in) :: missing_value
+ REAL, DIMENSION(2), 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
@@ -377,14 +383,6 @@ 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, &
@@ -406,8 +404,7 @@ 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
- CLASS(*), OPTIONAL, INTENT(in) :: missing_value
- CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range
+ REAL, OPTIONAL, INTENT(in) :: missing_value, RANGE(2)
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
@@ -445,14 +442,6 @@ 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,&
@@ -602,8 +591,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
- CLASS(*), OPTIONAL, INTENT(in) :: missing_value
- CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range
+ REAL, OPTIONAL, INTENT(in) :: missing_value
+ REAL, DIMENSION(2), 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
@@ -616,8 +605,7 @@ 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 !< Local copy of missing_value
- REAL, DIMENSION(2) :: range_use !< Local copy of range
+ REAL :: missing_value_use
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
@@ -636,15 +624,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
IF ( use_cmor ) THEN
missing_value_use = CMOR_MISSING_VALUE
ELSE
- 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
+ missing_value_use = missing_value
END IF
END IF
@@ -672,14 +652,6 @@ 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
@@ -799,18 +771,9 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name,
END IF
IF ( PRESENT(range) ) THEN
- 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
+ input_fields(field)%range = range
! don't use the range if it is not a valid range
- input_fields(field)%range_present = range_use(2) .gt. range_use(1)
+ input_fields(field)%range_present = range(2) .gt. range(1)
ELSE
input_fields(field)%range = (/ 1., 0. /)
input_fields(field)%range_present = .FALSE.
@@ -1276,45 +1239,35 @@ 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
- CLASS(*), INTENT(in) :: field
+ REAL, INTENT(in) :: field
TYPE(time_type), INTENT(in), OPTIONAL :: time
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
- REAL :: field_out(1, 1, 1) !< Local copy of field
+ REAL :: 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 = .FALSE.
RETURN
END IF
-
! First copy the data to a three d array with last element 1
- 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
-
+ field_out(1, 1, 1) = field
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
- CLASS(*), DIMENSION(:), INTENT(in) :: field
- CLASS(*), INTENT(in), OPTIONAL :: weight
- CLASS(*), INTENT(in), DIMENSION(:), OPTIONAL :: rmask
+ REAL, 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, DIMENSION(SIZE(field(:)), 1, 1) :: field_out !< Local copy of field
- LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out !< Local copy of mask
+ REAL, 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
@@ -1323,15 +1276,7 @@ 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
- 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
+ field_out(:, 1, 1) = field
! Default values for mask
IF ( PRESENT(mask) ) THEN
@@ -1340,18 +1285,7 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie
mask_out = .TRUE.
END IF
- 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(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 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,&
@@ -1374,16 +1308,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
- CLASS(*), INTENT(in), DIMENSION(:,:) :: field
- CLASS(*), INTENT(in), OPTIONAL :: weight
+ REAL, 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
- CLASS(*), INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask
+ REAL, INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
- 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
+ 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
@@ -1392,15 +1326,7 @@ 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
- 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
+ field_out(:, :, 1) = field
! Default values for mask
IF ( PRESENT(mask) ) THEN
@@ -1409,18 +1335,7 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, &
mask_out = .TRUE.
END IF
- 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(rmask) ) WHERE ( rmask < 0.5 ) mask_out(:, :, 1) = .FALSE.
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)
@@ -1430,16 +1345,168 @@ 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
- CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field
- CLASS(*), INTENT(in), OPTIONAL :: weight
+ REAL, DIMENSION(:,:,:), INTENT(in) :: 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, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask
- CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask
+ REAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask
CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg
REAL :: weight1
@@ -1473,8 +1540,6 @@ 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.
@@ -1497,23 +1562,6 @@ 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
@@ -1527,18 +1575,7 @@ 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) ) 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
+ IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) oor_mask = .FALSE.
! send_data works in either one or another of two modes.
! 1. Input field is a window (e.g. FMS physics)
@@ -1554,7 +1591,6 @@ 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
@@ -1562,7 +1598,6 @@ 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
@@ -1571,7 +1606,6 @@ 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
@@ -1579,7 +1613,6 @@ 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
@@ -1605,7 +1638,6 @@ 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
@@ -1613,7 +1645,6 @@ 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
@@ -1638,15 +1669,7 @@ 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
- 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
+ weight1 = weight
ELSE
weight1 = 1.
END IF
@@ -1675,13 +1698,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_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))
+ & 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))
IF ( missvalue_present ) THEN
IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.&
- & ((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
+ & ((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
!
! A value for in field (Min: , Max: )
! is outside the range [,] and not equal to the missing
@@ -1698,8 +1721,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_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
+ & (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
!
! A value for in field (Min: , Max: )
! is outside the range [,].
@@ -1749,7 +1772,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_out(f1:f2,f3:f4,ks:ke)) ) THEN
+ IF ( output_fields(out_num)%total_elements > SIZE(field(f1:f2,f3:f4,ks:ke)) ) THEN
output_fields(out_num)%phys_window = .TRUE.
ELSE
output_fields(out_num)%phys_window = .FALSE.
@@ -1793,7 +1816,6 @@ 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
@@ -1806,7 +1828,6 @@ 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
@@ -1826,7 +1847,6 @@ 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
@@ -1838,7 +1858,6 @@ 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
@@ -1853,7 +1872,6 @@ 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
@@ -1869,7 +1887,6 @@ 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
@@ -1884,7 +1901,6 @@ 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
@@ -1900,11 +1916,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_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi, j-js+1+hj, k) * weight1
+ & field(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
@@ -1920,11 +1936,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_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k)*weight1
+ & field(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
@@ -1944,11 +1960,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_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi, j-js+1+hj, k) * weight1
+ & field(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
@@ -1964,11 +1980,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_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k)*weight1
+ & field(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
@@ -1985,7 +2001,6 @@ 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
@@ -1996,7 +2011,6 @@ 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
@@ -2017,11 +2031,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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
@@ -2043,11 +2057,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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
@@ -2078,11 +2092,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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(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
@@ -2100,11 +2114,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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(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
@@ -2120,7 +2134,6 @@ 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
@@ -2134,11 +2147,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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(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
@@ -2155,11 +2168,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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(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
@@ -2203,10 +2216,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_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
+ & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
END IF
END IF
END DO
@@ -2220,10 +2233,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_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
+ & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
END IF
END IF
END DO
@@ -2248,11 +2261,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_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
+ & (field(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_out(f1:f2,f3:f4,ksr:ker)*weight1
+ & field(f1:f2,f3:f4,ksr:ker)*weight1
END IF
ELSE
!$OMP CRITICAL
@@ -2261,11 +2274,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_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
+ & (field(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_out(f1:f2,f3:f4,ksr:ker)*weight1
+ & field(f1:f2,f3:f4,ksr:ker)*weight1
END IF
!$OMP END CRITICAL
END IF
@@ -2275,7 +2288,6 @@ 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
@@ -2285,22 +2297,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_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
+ & (field(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_out(f1:f2,f3:f4,ks:ke)*weight1
+ & field(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_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
+ & (field(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_out(f1:f2,f3:f4,ks:ke)*weight1
+ & field(f1:f2,f3:f4,ks:ke)*weight1
END IF
!$OMP END CRITICAL
END IF
@@ -2321,15 +2333,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_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
@@ -2347,15 +2359,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_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(i-is+1+hi,j-js+1+hj,k) * weight1
END IF
ELSE
output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue
@@ -2379,7 +2391,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_out(i,j,k) /= missvalue ) THEN
+ IF ( field(i,j,k) /= missvalue ) THEN
output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1
EXIT outer0
END IF
@@ -2396,15 +2408,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_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(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
@@ -2420,15 +2432,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_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(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
@@ -2443,7 +2455,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_out(i,j,k) /= missvalue ) THEN
+ IF ( field(i,j,k) /= missvalue ) THEN
output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1
EXIT outer3
END IF
@@ -2457,7 +2469,6 @@ 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
@@ -2467,15 +2478,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_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(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
@@ -2488,15 +2499,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_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN
+ IF ( field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,k) * weight1
+ & field(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
@@ -2510,7 +2521,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_out(i,j,k) /= missvalue ) THEN
+ IF ( field(i,j,k) /= missvalue ) THEN
output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1
EXIT outer1
END IF
@@ -2529,10 +2540,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_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
+ & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
END IF
END IF
END DO
@@ -2546,10 +2557,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_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value)
+ & (field(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_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
+ & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1
END IF
END IF
END DO
@@ -2575,22 +2586,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_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
+ & (field(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_out(f1:f2,f3:f4,ksr:ker)*weight1
+ & field(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_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value)
+ & (field(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_out(f1:f2,f3:f4,ksr:ker)*weight1
+ & field(f1:f2,f3:f4,ksr:ker)*weight1
END IF
!$OMP END CRITICAL
END IF
@@ -2600,7 +2611,6 @@ 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
@@ -2610,22 +2620,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_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
+ & (field(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_out(f1:f2,f3:f4,ks:ke)*weight1
+ & field(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_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value)
+ & (field(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_out(f1:f2,f3:f4,ks:ke)*weight1
+ & field(f1:f2,f3:f4,ks:ke)*weight1
END IF
!$OMP END CRITICAL
END IF
@@ -2657,8 +2667,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_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)
+ & 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)
END IF
END IF
END DO
@@ -2669,23 +2679,22 @@ 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_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)
+ & 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)
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_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)
+ & 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)
END IF
ELSE
IF ( need_compute ) THEN
@@ -2696,8 +2705,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_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)
+ 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)
END IF
END IF
END DO
@@ -2707,22 +2716,21 @@ 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_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)
+ 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)
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_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)
+ 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)
END IF
END IF
output_fields(out_num)%count_0d(sample) = 1
@@ -2737,8 +2745,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_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)
+ & 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)
END IF
END IF
END DO
@@ -2749,23 +2757,22 @@ 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_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)
+ & 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)
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_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)
+ & 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)
END IF
ELSE
IF ( need_compute ) THEN
@@ -2776,8 +2783,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_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)
+ 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)
END IF
END IF
END DO
@@ -2787,22 +2794,21 @@ 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_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)
+ 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)
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_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)
+ 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)
END IF
END IF
output_fields(out_num)%count_0d(sample) = 1
@@ -2819,7 +2825,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_out(i-is+1+hi,j-js+1+hj,k)
+ field(i-is+1+hi,j-js+1+hj,k)
END IF
END IF
END DO
@@ -2831,14 +2837,13 @@ 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_out(f1:f2,f3:f4,ksr:ker)
+ & field(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
@@ -2847,7 +2852,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_out(f1:f2,f3:f4,ks:ke)
+ & field(f1:f2,f3:f4,ks:ke)
END IF
ELSE
IF ( need_compute ) THEN
@@ -2860,7 +2865,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_out(i-is+1+hi,j-js+1+hj,k)
+ & field(i-is+1+hi,j-js+1+hj,k)
END IF
END DO
END DO
@@ -2870,14 +2875,13 @@ 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_out(f1:f2,f3:f4,ksr:ker)
+ & field(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
@@ -2885,7 +2889,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_out(f1:f2,f3:f4,ks:ke)
+ & field(f1:f2,f3:f4,ks:ke)
END IF
END IF
output_fields(out_num)%count_0d(sample) = 1
@@ -2897,7 +2901,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_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
+ output_fields(out_num)%buffer(i1,j1,:,sample) = field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))
END IF
END DO
END DO
@@ -2905,20 +2909,19 @@ 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_out(f1:f2,f3:f4,ksr:ker)
+ output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(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_out(f1:f2,f3:f4,ks:ke)
+ output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke)
END IF
IF ( PRESENT(mask) .AND. missvalue_present ) THEN
@@ -2965,7 +2968,6 @@ 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,97 +2977,45 @@ 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
- 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
- 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
+ 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
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 DO
ELSE IF ( reduced_k_range ) THEN
ksr= l_start(3)
ker= l_end(3)
- 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
+ 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
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
+ END DO
ELSE
- 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
+ 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
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 DO
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 10598cedf1..618702c30e 100644
--- a/diag_manager/diag_util.F90
+++ b/diag_manager/diag_util.F90
@@ -632,8 +632,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.
- CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value.
- CLASS(*), DIMENSION(:), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field.
+ REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value value.
+ REAL, DIMENSION(2), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field.
LOGICAL, OPTIONAL, INTENT(in) :: dynamic !< .TRUE. if field is not static.
! ---- local vars
@@ -643,20 +643,10 @@ 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)
@@ -678,33 +668,15 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,&
IF ( use_cmor ) THEN
WRITE (lmissval,*) CMOR_MISSING_VALUE
ELSE
- 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
+ WRITE (lmissval,*) missing_value
END IF
ELSE
lmissval = ''
ENDIF
IF ( PRESENT(range) ) THEN
- 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)
+ WRITE (lmin,*) range(1)
+ WRITE (lmax,*) range(2)
ELSE
lmin = ''
lmax = ''
diff --git a/sat_vapor_pres/sat_vapor_pres.F90 b/sat_vapor_pres/sat_vapor_pres.F90
index 054860e530..c92e134a94 100644
--- a/sat_vapor_pres/sat_vapor_pres.F90
+++ b/sat_vapor_pres/sat_vapor_pres.F90
@@ -194,8 +194,6 @@ 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
@@ -741,8 +739,8 @@ module sat_vapor_pres_mod
!
subroutine lookup_es_0d ( temp, esat, err_msg )
- class(*), intent(in) :: temp
- class(*), intent(out) :: esat
+ real, intent(in) :: temp
+ real, intent(out) :: esat
character(len=*), intent(out), optional :: err_msg
integer :: nbad
@@ -773,8 +771,8 @@ end subroutine lookup_es_0d
!
subroutine lookup_es_1d ( temp, esat, err_msg )
- class(*), intent(in) :: temp(:)
- class(*), intent(out) :: esat(:)
+ real, intent(in) :: temp(:)
+ real, intent(out) :: esat(:)
character(len=*), intent(out), optional :: err_msg
character(len=54) :: err_msg_local
@@ -809,8 +807,8 @@ end subroutine lookup_es_1d
!
subroutine lookup_es_2d ( temp, esat, err_msg )
- class(*), intent(in) :: temp(:,:)
- class(*), intent(out) :: esat(:,:)
+ real, intent(in) :: temp(:,:)
+ real, intent(out) :: esat(:,:)
character(len=*), intent(out), optional :: err_msg
character(len=54) :: err_msg_local
@@ -845,8 +843,8 @@ end subroutine lookup_es_2d
!
subroutine lookup_es_3d ( temp, esat, err_msg )
- class(*), intent(in) :: temp(:,:,:)
- class(*), intent(out) :: esat(:,:,:)
+ real, intent(in) :: temp(:,:,:)
+ real, intent(out) :: esat(:,:,:)
character(len=*), intent(out), optional :: err_msg
integer :: nbad
@@ -1977,10 +1975,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 )
- class(*), intent(in) :: temp, press
- class(*), intent(out) :: qsat
- class(*), intent(in), optional :: q, hc
- class(*), intent(out), optional :: dqsdT, esat
+ real, intent(in) :: temp, press
+ real, intent(out) :: qsat
+ real, intent(in), optional :: q, hc
+ real, 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
@@ -2035,11 +2033,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 )
- 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(:)
+ 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(:)
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
@@ -2097,11 +2095,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 )
- 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(:,:)
+ 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(:,:)
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
@@ -2158,11 +2156,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 )
- 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(:,:,:)
+ 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(:,:,:)
character(len=*), intent(out), optional :: err_msg
logical,intent(in), optional :: es_over_liq
logical,intent(in), optional :: es_over_liq_and_ice
@@ -2610,245 +2608,131 @@ end subroutine sat_vapor_pres_init
!#######################################################################
function check_1d ( temp ) result ( nbad )
- class(*), intent(in) :: temp(:)
+ real , intent(in) :: temp(:)
integer :: nbad, ind, i
nbad = 0
-
- 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
+ do i = 1, size(temp,1)
+ ind = int(dtinv*(temp(i)-tmin+teps))
+ if (ind < 0 .or. ind > nlim) nbad = nbad+1
+ enddo
end function check_1d
!------------------------------------------------
function check_2d ( temp ) result ( nbad )
- class(*), intent(in) :: temp(:,:)
+ real , intent(in) :: temp(:,:)
integer :: nbad
integer :: j
- 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
-
+ nbad = 0
+ do j = 1, size(temp,2)
+ nbad = nbad + check_1d ( temp(:,j) )
+ enddo
end function check_2d
!#######################################################################
subroutine temp_check_1d ( temp )
- class(*), intent(in) :: temp(:)
+ real , intent(in) :: temp(:)
integer :: i, unit
unit = stdoutunit
-
- 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
+ write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1))
end subroutine temp_check_1d
!--------------------------------------------------------------
subroutine temp_check_2d ( temp )
- class(*), intent(in) :: temp(:,:)
+ real , intent(in) :: temp(:,:)
integer :: i, j, unit
unit = stdoutunit
-
- 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
+ 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))
end subroutine temp_check_2d
!--------------------------------------------------------------
subroutine temp_check_3d ( temp )
- class(*), intent(in) :: temp(:,:,:)
+ real, intent(in) :: temp(:,:,:)
integer :: i, j, k, unit
unit = stdoutunit
-
- 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
+ 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))
end subroutine temp_check_3d
!#######################################################################
subroutine show_all_bad_0d ( temp )
- class(*), intent(in) :: temp
+ real , intent(in) :: temp
integer :: ind, unit
unit = stdoutunit
-
- 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
+ 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
end subroutine show_all_bad_0d
!--------------------------------------------------------------
subroutine show_all_bad_1d ( temp )
- class(*), intent(in) :: temp(:)
+ real , intent(in) :: temp(:)
integer :: i, ind, unit
unit = stdoutunit
-
- 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
+ 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
end subroutine show_all_bad_1d
!--------------------------------------------------------------
subroutine show_all_bad_2d ( temp )
- class(*), intent(in) :: temp(:,:)
+ real , intent(in) :: temp(:,:)
integer :: i, j, ind, unit
unit = stdoutunit
-
- 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
+ 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
end subroutine show_all_bad_2d
!--------------------------------------------------------------
subroutine show_all_bad_3d ( temp )
- class(*), intent(in) :: temp(:,:,:)
+ real, intent(in) :: temp(:,:,:)
integer :: i, j, k, ind, unit
unit = stdoutunit
-
- 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
+ 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
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 3a1ba4f43b..a9662a7d3b 100644
--- a/sat_vapor_pres/sat_vapor_pres_k.F90
+++ b/sat_vapor_pres/sat_vapor_pres_k.F90
@@ -50,9 +50,6 @@ 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
@@ -478,323 +475,85 @@ 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)
- 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
+ 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
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
- 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
+ hc_loc = hc
else
hc_loc = 1.0
endif
-
- 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
+ if (present(es_over_liq)) then
+ if (present (dqsdT)) then
+ call lookup_es2_des2_k (temp, esloc, desat, nbad)
+ desat = desat*hc_loc
else
- 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
+ call lookup_es2_k (temp, esloc, nbad)
endif
-
- 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
-
+ 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
+ else
+ call lookup_es_k (temp, esloc, nbad)
+ endif
+ endif
+ esloc = esloc*hc_loc
if (present (esat)) then
- select type (esat)
- type is (real(kind=r4_kind))
- esat = esloc_r4
- type is (real(kind=r8_kind))
- esat = esloc_r8
- end select
+ esat = esloc
endif
-
if (nbad == 0) then
- 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
- 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
+ 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
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
+ end do
+ end do
+ if (present (dqsdT)) then
+ dqsdT = eps*press*desat/denom**2
+ endif
+ endif ! (present(q))
else ! (nbad = 0)
- select type (qs)
- type is (real(kind=r4_kind))
- qs = -999.0_r4_kind
- type is (real(kind=r8_kind))
- qs = -999.
- end select
+ qs = -999.
if (present (dqsdT)) then
- select type (dqsdT)
- type is (real(kind=r4_kind))
- dqsdT = -999.0_r4_kind
- type is (real(kind=r8_kind))
- dqsdT = -999.
- end select
+ dqsdT = -999.
endif
if (present (esat)) then
- select type (esat)
- type is (real(kind=r4_kind))
- esat = -999.0_r4_kind
- type is (real(kind=r8_kind))
- esat = -999.
- end select
+ esat = -999.
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
@@ -803,319 +562,83 @@ 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)
- 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
+ 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
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
- 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
+ hc_loc = hc
else
hc_loc = 1.0
endif
- 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
+ if (present(es_over_liq)) then
+ if (present (dqsdT)) then
+ call lookup_es2_des2_k (temp, esloc, desat, nbad)
+ desat = desat*hc_loc
else
- 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
+ call lookup_es2_k (temp, esloc, nbad)
endif
-
- 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
-
+ 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
+ else
+ call lookup_es_k (temp, esloc, nbad)
+ endif
+ endif
+ esloc = esloc*hc_loc
if (present (esat)) then
- select type (esat)
- type is (real(kind=r4_kind))
- esat = esloc_r4
- type is (real(kind=r8_kind))
- esat = esloc_r8
- end select
+ esat = esloc
endif
-
if (nbad == 0) then
- 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
+ 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))
else ! (nbad = 0)
- select type (qs)
- type is (real(kind=r4_kind))
- qs = -999.0_r4_kind
- type is (real(kind=r8_kind))
- qs = -999.
- end select
+ qs = -999.
if (present (dqsdT)) then
- select type (dqsdT)
- type is (real(kind=r4_kind))
- dqsdT = -999.0_r4_kind
- type is (real(kind=r8_kind))
- dqsdT = -999.
- end select
+ dqsdT = -999.
endif
if (present (esat)) then
- select type (esat)
- type is (real(kind=r4_kind))
- esat = -999.0_r4_kind
- type is (real(kind=r8_kind))
- esat = -999.
- end select
+ esat = -999.
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
@@ -1124,315 +647,81 @@ 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)
- 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
+ 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
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
- 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
+ hc_loc = hc
else
hc_loc = 1.0
endif
- 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
+ if (present(es_over_liq)) then
+ if (present (dqsdT)) then
+ call lookup_es2_des2_k (temp, esloc, desat, nbad)
+ desat = desat*hc_loc
else
- 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
+ call lookup_es2_k (temp, esloc, nbad)
endif
-
- 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
-
+ 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
+ else
+ call lookup_es_k (temp, esloc, nbad)
+ endif
+ endif
+ esloc = esloc*hc_loc
if (present (esat)) then
- select type (esat)
- type is (real(kind=r4_kind))
- esat = esloc_r4
- type is (real(kind=r8_kind))
- esat = esloc_r8
- end select
+ esat = esloc
endif
-
if (nbad == 0) then
- 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
+ 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))
else ! (nbad = 0)
- select type (qs)
- type is (real(kind=r4_kind))
- qs = -999.0_r4_kind
- type is (real(kind=r8_kind))
- qs = -999.
- end select
+ qs = -999.
if (present (dqsdT)) then
- select type (dqsdT)
- type is (real(kind=r4_kind))
- dqsdT = -999.0_r4_kind
- type is (real(kind=r8_kind))
- dqsdT = -999.
- end select
+ dqsdT = -999.
endif
if (present (esat)) then
- select type (esat)
- type is (real(kind=r4_kind))
- esat = -999.0_r4_kind
- type is (real(kind=r8_kind))
- esat = -999.
- end select
+ esat = -999.
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
@@ -1441,293 +730,79 @@ 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)
- class(*), intent(in) :: temp, press
+ real, intent(in) :: temp, press
real, intent(in) :: eps, zvir
- class(*), intent(out) :: qs
+ real, intent(out) :: qs
integer, intent(out) :: nbad
- class(*), intent(in), optional :: q
- class(*), intent(in), optional :: hc
- class(*), intent(out), optional :: dqsdT, esat
+ real, intent(in), optional :: q
+ real, intent(in), optional :: hc
+ real, 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(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 :: esloc, desat, denom
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
- 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
+ hc_loc = hc
else
hc_loc = 1.0
endif
- 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
+ if (present(es_over_liq)) then
+ if (present (dqsdT)) then
+ call lookup_es2_des2_k (temp, esloc, desat, nbad)
+ desat = desat*hc_loc
else
- 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
+ call lookup_es2_k (temp, esloc, nbad)
endif
-
- 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
-
+ 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
+ else
+ call lookup_es_k (temp, esloc, nbad)
+ endif
+ endif
+ esloc = esloc*hc_loc
if (present (esat)) then
- select type (esat)
- type is (real(kind=r4_kind))
- esat = esloc_r4
- type is (real(kind=r8_kind))
- esat = esloc_r8
- end select
+ esat = esloc
endif
-
if (nbad == 0) then
- 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
+ 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))
else ! (nbad = 0)
- select type (qs)
- type is (real(kind=r4_kind))
- qs = -999.0_r4_kind
- type is (real(kind=r8_kind))
- qs = -999.
- end select
+ qs = -999.
if (present (dqsdT)) then
- select type (dqsdT)
- type is (real(kind=r4_kind))
- dqsdT = -999.0_r4_kind
- type is (real(kind=r8_kind))
- dqsdT = -999.
- end select
+ dqsdT = -999.
endif
if (present (esat)) then
- select type (esat)
- type is (real(kind=r4_kind))
- esat = -999.0_r4_kind
- type is (real(kind=r8_kind))
- esat = -999.
- end select
+ esat = -999.
endif
endif ! (nbad = 0)
+
end subroutine compute_qs_k_0d
!#######################################################################
@@ -2073,292 +1148,107 @@ end subroutine compute_mrs_k_0d
!#######################################################################
subroutine lookup_es_des_k_3d (temp, esat, desat, nbad)
- class(*), intent(in), dimension(:,:,:) :: temp
- class(*), intent(out), dimension(:,:,:) :: esat, desat
+ real, intent(in), dimension(:,:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es_des_k_3d
!#######################################################################
subroutine lookup_es_des_k_2d (temp, esat, desat, nbad)
- class(*), intent(in), dimension(:,:) :: temp
- class(*), intent(out), dimension(:,:) :: esat, desat
+ real, intent(in), dimension(:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es_des_k_2d
!#######################################################################
subroutine lookup_es_des_k_1d (temp, esat, desat, nbad)
- class(*), intent(in), dimension(:) :: temp
- class(*), intent(out), dimension(:) :: esat, desat
+ real, intent(in), dimension(:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es_des_k_1d
!#######################################################################
subroutine lookup_es_des_k_0d (temp, esat, desat, nbad)
- class(*), intent(in) :: temp
- class(*), intent(out) :: esat, desat
+ real, intent(in) :: temp
+ real, intent(out) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
-
- 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
-
+ tmp = temp-tminl
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- 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
+ esat = TABLE(ind+1) + &
+ del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
+ desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
endif
end subroutine lookup_es_des_k_0d
@@ -2366,754 +1256,289 @@ end subroutine lookup_es_des_k_0d
!#######################################################################
subroutine lookup_es_k_3d(temp, esat, nbad)
- class(*), intent(in), dimension(:,:,:) :: temp
- class(*), intent(out), dimension(:,:,:) :: esat
+ real, intent(in), dimension(:,:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es_k_3d
!#######################################################################
subroutine lookup_des_k_3d(temp, desat, nbad)
- class(*), intent(in), dimension(:,:,:) :: temp
- class(*), intent(out), dimension(:,:,:) :: desat
+ real, intent(in), dimension(:,:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_des_k_3d
!#######################################################################
subroutine lookup_des_k_2d(temp, desat, nbad)
- class(*), intent(in), dimension(:,:) :: temp
- class(*), intent(out), dimension(:,:) :: desat
+ real, intent(in), dimension(:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_des_k_2d
!#######################################################################
subroutine lookup_es_k_2d(temp, esat, nbad)
- class(*), intent(in), dimension(:,:) :: temp
- class(*), intent(out), dimension(:,:) :: esat
+ real, intent(in), dimension(:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es_k_2d
!#######################################################################
subroutine lookup_des_k_1d(temp, desat, nbad)
- class(*), intent(in), dimension(:) :: temp
- class(*), intent(out), dimension(:) :: desat
+ real, intent(in), dimension(:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_des_k_1d
!#######################################################################
subroutine lookup_es_k_1d(temp, esat, nbad)
- class(*), intent(in), dimension(:) :: temp
- class(*), intent(out), dimension(:) :: esat
+ real, intent(in), dimension(:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es_k_1d
!#######################################################################
subroutine lookup_des_k_0d(temp, desat, nbad)
- class(*), intent(in) :: temp
- class(*), intent(out) :: desat
+ real, intent(in) :: temp
+ real, intent(out) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
-
- 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
-
+ tmp = temp-tminl
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- 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
+ desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1)
endif
end subroutine lookup_des_k_0d
!#######################################################################
subroutine lookup_es_k_0d(temp, esat, nbad)
- class(*), intent(in) :: temp
- class(*), intent(out) :: esat
+ real, intent(in) :: temp
+ real, intent(out) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
-
- 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
-
+ tmp = temp-tminl
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- 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
+ esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1))
endif
end subroutine lookup_es_k_0d
!#######################################################################
subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad)
- class(*), intent(in), dimension(:,:,:) :: temp
- class(*), intent(out), dimension(:,:,:) :: esat, desat
+ real, intent(in), dimension(:,:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es2_des2_k_3d
!#######################################################################
subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad)
- class(*), intent(in), dimension(:,:) :: temp
- class(*), intent(out), dimension(:,:) :: esat, desat
+ real, intent(in), dimension(:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es2_des2_k_2d
!#######################################################################
subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad)
- class(*), intent(in), dimension(:) :: temp
- class(*), intent(out), dimension(:) :: esat, desat
+ real, intent(in), dimension(:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es2_des2_k_1d
!#######################################################################
subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad)
- class(*), intent(in) :: temp
- class(*), intent(out) :: esat, desat
+ real, intent(in) :: temp
+ real, intent(out) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
-
- 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
-
+ tmp = temp-tminl
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- 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
+ esat = TABLE2(ind+1) + &
+ del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
+ desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
endif
end subroutine lookup_es2_des2_k_0d
@@ -3121,462 +1546,182 @@ end subroutine lookup_es2_des2_k_0d
!#######################################################################
subroutine lookup_es2_k_3d(temp, esat, nbad)
- class(*), intent(in), dimension(:,:,:) :: temp
- class(*), intent(out), dimension(:,:,:) :: esat
+ real, intent(in), dimension(:,:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es2_k_3d
!#######################################################################
subroutine lookup_des2_k_3d(temp, desat, nbad)
- class(*), intent(in), dimension(:,:,:) :: temp
- class(*), intent(out), dimension(:,:,:) :: desat
+ real, intent(in), dimension(:,:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_des2_k_3d
!#######################################################################
subroutine lookup_des2_k_2d(temp, desat, nbad)
- class(*), intent(in), dimension(:,:) :: temp
- class(*), intent(out), dimension(:,:) :: desat
+ real, intent(in), dimension(:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_des2_k_2d
!#######################################################################
subroutine lookup_es2_k_2d(temp, esat, nbad)
- class(*), intent(in), dimension(:,:) :: temp
- class(*), intent(out), dimension(:,:) :: esat
+ real, intent(in), dimension(:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es2_k_2d
!#######################################################################
subroutine lookup_des2_k_1d(temp, desat, nbad)
- class(*), intent(in), dimension(:) :: temp
- class(*), intent(out), dimension(:) :: desat
+ real, intent(in), dimension(:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_des2_k_1d
!#######################################################################
subroutine lookup_es2_k_1d(temp, esat, nbad)
- class(*), intent(in), dimension(:) :: temp
- class(*), intent(out), dimension(:) :: esat
+ real, intent(in), dimension(:) :: temp
+ real, 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)
- class(*), intent(in) :: temp
- class(*), intent(out) :: desat
+ real, intent(in) :: temp
+ real, intent(out) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
-
- 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
-
+ tmp = temp-tminl
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- 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
+ desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1)
endif
end subroutine lookup_des2_k_0d
!#######################################################################
subroutine lookup_es2_k_0d(temp, esat, nbad)
- class(*), intent(in) :: temp
- class(*), intent(out) :: esat
+ real, intent(in) :: temp
+ real, intent(out) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
-
- 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
-
+ tmp = temp-tminl
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- 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
+ esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))
endif
end subroutine lookup_es2_k_0d
@@ -3585,292 +1730,107 @@ end subroutine lookup_es2_k_0d
!#######################################################################
subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad)
- class(*), intent(in), dimension(:,:,:) :: temp
- class(*), intent(out), dimension(:,:,:) :: esat, desat
+ real, intent(in), dimension(:,:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es3_des3_k_3d
!#######################################################################
subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad)
- class(*), intent(in), dimension(:,:) :: temp
- class(*), intent(out), dimension(:,:) :: esat, desat
+ real, intent(in), dimension(:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es3_des3_k_2d
!#######################################################################
subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad)
- class(*), intent(in), dimension(:) :: temp
- class(*), intent(out), dimension(:) :: esat, desat
+ real, intent(in), dimension(:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es3_des3_k_1d
!#######################################################################
subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad)
- class(*), intent(in) :: temp
- class(*), intent(out) :: esat, desat
+ real, intent(in) :: temp
+ real, intent(out) :: esat, desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
-
- 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
-
+ tmp = temp-tminl
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- 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
+ esat = TABLE3(ind+1) + &
+ del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
+ desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
endif
end subroutine lookup_es3_des3_k_0d
@@ -3878,462 +1838,182 @@ end subroutine lookup_es3_des3_k_0d
!#######################################################################
subroutine lookup_es3_k_3d(temp, esat, nbad)
- class(*), intent(in), dimension(:,:,:) :: temp
- class(*), intent(out), dimension(:,:,:) :: esat
+ real, intent(in), dimension(:,:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es3_k_3d
!#######################################################################
subroutine lookup_des3_k_3d(temp, desat, nbad)
- class(*), intent(in), dimension(:,:,:) :: temp
- class(*), intent(out), dimension(:,:,:) :: desat
+ real, intent(in), dimension(:,:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_des3_k_3d
!#######################################################################
subroutine lookup_des3_k_2d(temp, desat, nbad)
- class(*), intent(in), dimension(:,:) :: temp
- class(*), intent(out), dimension(:,:) :: desat
+ real, intent(in), dimension(:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_des3_k_2d
!#######################################################################
subroutine lookup_es3_k_2d(temp, esat, nbad)
- class(*), intent(in), dimension(:,:) :: temp
- class(*), intent(out), dimension(:,:) :: esat
+ real, intent(in), dimension(:,:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es3_k_2d
!#######################################################################
subroutine lookup_des3_k_1d(temp, desat, nbad)
- class(*), intent(in), dimension(:) :: temp
- class(*), intent(out), dimension(:) :: desat
+ real, intent(in), dimension(:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_des3_k_1d
!#######################################################################
subroutine lookup_es3_k_1d(temp, esat, nbad)
- class(*), intent(in), dimension(:) :: temp
- class(*), intent(out), dimension(:) :: esat
+ real, intent(in), dimension(:) :: temp
+ real, 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
-
- 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
+ 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
end subroutine lookup_es3_k_1d
!#######################################################################
subroutine lookup_des3_k_0d(temp, desat, nbad)
- class(*), intent(in) :: temp
- class(*), intent(out) :: desat
+ real, intent(in) :: temp
+ real, intent(out) :: desat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
-
- 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
-
+ tmp = temp-tminl
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- 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
+ desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1)
endif
end subroutine lookup_des3_k_0d
!#######################################################################
subroutine lookup_es3_k_0d(temp, esat, nbad)
- class(*), intent(in) :: temp
- class(*), intent(out) :: esat
+ real, intent(in) :: temp
+ real, intent(out) :: esat
integer, intent(out) :: nbad
real :: tmp, del
integer :: ind
nbad = 0
-
- 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
-
+ tmp = temp-tminl
ind = int(dtinvl*(tmp+tepsl))
if (ind < 0 .or. ind >= table_siz) then
nbad = nbad+1
else
del = tmp-dtres*real(ind)
- 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
+ esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))
endif
end subroutine lookup_es3_k_0d
diff --git a/time_manager/time_manager.F90 b/time_manager/time_manager.F90
index 02eee5721c..b77355ced1 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: r4_kind, r8_kind
+use platform_mod, only: 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)
- class(*),intent(in) :: x !< Number of seconds.
+ real,intent(in) :: x !< Number of seconds.
character(len=*),intent(out),optional :: err_msg !< Error message.
type(time_type) :: t
integer :: days
@@ -1213,29 +1213,9 @@ function real_to_time_type(x,err_msg) result(t)
real :: tps
real :: a
tps = real(ticks_per_second)
-
- 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
-
+ a = x/spd
days = safe_rtoi(a,do_floor)
-
- 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
-
+ a = x - real(days)*spd
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 348b704a81..79ea8ac623 100644
--- a/tracer_manager/tracer_manager.F90
+++ b/tracer_manager/tracer_manager.F90
@@ -76,8 +76,6 @@ module tracer_manager_mod
fm_exists, &
MODEL_NAMES
-use platform_mod, only: r4_kind, r8_kind
-
implicit none
private
@@ -1039,7 +1037,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
-class(*), intent(inout), dimension(:,:,:) :: tracer !< Initialized tracer array
+real, intent(inout), dimension(:,:,:) :: tracer !< Initialized tracer array
character(len=*), intent(out), optional :: err_msg
real :: surf_value, multiplier
@@ -1065,14 +1063,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg)
bottom_value = surf_value
multiplier = 1.0
-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
+tracer = surf_value
if ( query_method ( 'profile_type',model,n,scheme,control)) then
!Change the tracer_number to the tracer_manager version
@@ -1081,14 +1072,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg)
profile_type = 'Fixed'
flag =parse(control,'surface_value',surf_value)
multiplier = 1.0
- 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
+ tracer = surf_value
endif
if(lowercase(trim(scheme(1:7))).eq.'profile') then
@@ -1121,36 +1105,16 @@ 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)
- 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
+ tracer(:,:,1) = surf_value
+ do k = 2, size(tracer,3)
+ tracer(:,:,k) = tracer(:,:,k-1) * multiplier
+ enddo
case (MODEL_OCEAN)
multiplier = exp( log (bottom_value/surf_value) /numlevels)
- 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
+ tracer(:,:,size(tracer,3)) = surf_value
+ do k = size(tracer,3) - 1, 1, -1
+ tracer(:,:,k) = tracer(:,:,k+1) * multiplier
+ enddo
case default
end select
endif !scheme.eq.profile