From a22e1943344e7e48588ea1966efea0bfd41871ce Mon Sep 17 00:00:00 2001 From: rem1776 Date: Wed, 23 Nov 2022 15:03:37 -0500 Subject: [PATCH 01/53] Revert "feat: emc mixedmode support (#997)" This reverts commit 8a4ad847122c7cc597a1f2626290b46af44b143a. --- CMakeLists.txt | 3 - Makefile.am | 1 - configure.ac | 1 - constants4/constantsr4.F90 | 33 - constants4/fmsconstantsr4.F90 | 99 - constants4/geos_constantsR4.h | 97 - constants4/gfdl_constantsR4.h | 97 - constants4/gfs_constantsR4.h | 100 - diag_manager/diag_axis.F90 | 24 +- diag_manager/diag_grid.F90 | 73 +- diag_manager/diag_manager.F90 | 721 +++--- diag_manager/diag_util.F90 | 38 +- sat_vapor_pres/sat_vapor_pres.F90 | 275 +- sat_vapor_pres/sat_vapor_pres_k.F90 | 3701 +++++---------------------- time_manager/time_manager.F90 | 28 +- tracer_manager/tracer_manager.F90 | 62 +- 16 files changed, 1109 insertions(+), 4244 deletions(-) delete mode 100644 constants4/constantsr4.F90 delete mode 100644 constants4/fmsconstantsr4.F90 delete mode 100644 constants4/geos_constantsR4.h delete mode 100644 constants4/gfdl_constantsR4.h delete mode 100644 constants4/gfs_constantsR4.h diff --git a/CMakeLists.txt b/CMakeLists.txt index 6a28c81da5..c68e000e31 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -109,8 +109,6 @@ list(APPEND fms_fortran_src_files column_diagnostics/column_diagnostics.F90 constants/constants.F90 constants/fmsconstants.F90 - constants4/constantsr4.F90 - constants4/fmsconstantsr4.F90 coupler/atmos_ocean_fluxes.F90 coupler/coupler_types.F90 coupler/ensemble_manager.F90 @@ -292,7 +290,6 @@ foreach(kind ${kinds}) fms fms2_io/include mpp/include - constants4 constants) target_compile_definitions(${libTgt}_f PRIVATE "${fms_defs}") target_compile_definitions(${libTgt}_f PRIVATE "${${kind}_defs}") diff --git a/Makefile.am b/Makefile.am index ffb12344ea..2b2a1e9dc8 100644 --- a/Makefile.am +++ b/Makefile.am @@ -38,7 +38,6 @@ SUBDIRS = \ tridiagonal \ mpp \ constants \ - constants4 \ memutils \ string_utils \ fms2_io \ diff --git a/configure.ac b/configure.ac index b0b8bb309d..89d0ba9b9d 100644 --- a/configure.ac +++ b/configure.ac @@ -418,7 +418,6 @@ AC_CONFIG_FILES([ time_interp/Makefile time_manager/Makefile constants/Makefile - constants4/Makefile platform/Makefile fms/Makefile fms2_io/Makefile diff --git a/constants4/constantsr4.F90 b/constants4/constantsr4.F90 deleted file mode 100644 index 78c4da27a4..0000000000 --- a/constants4/constantsr4.F90 +++ /dev/null @@ -1,33 +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 constantsR4_mod constantsR4_mod -!> @ingroup constantsR4 -!> @brief compatibility module as we transition to an FMSConstantsR4 module -!! -!> @file -!> @brief File for @ref constantsR4_mod - -module constantsR4_mod - -!> rename to not conflict with any other version vars -use FMSConstantsR4, version => constantsR4_version, constants_init => FMSconstantsR4_init - -contains - -end module constantsR4_mod diff --git a/constants4/fmsconstantsr4.F90 b/constants4/fmsconstantsr4.F90 deleted file mode 100644 index 76267101d6..0000000000 --- a/constants4/fmsconstantsr4.F90 +++ /dev/null @@ -1,99 +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 fmsconstantsR4 FMSConstantsR4 -!> @ingroup libfms -!> @brief Defines useful constants for Earth. Constants are defined as real -!! -!> FMSconstantsR4 have been declared as r4_kind or r8_kind PARAMETER. -!! -!! The value of a constant defined and used from here cannot be changed -!! in a users program. New constants can be defined in terms of values -!! from the FMSconstants module and their includes using a parameter -!! statement.

-!! -!! The currently support contant systems are: -!! GFDL constants (gfdl_constantsR4.h) -!! GEOS constants (geos_constantsR4.h) -!! GFS constants (gfs_constantsR4.h) -!!

-!! -!! The name given to a particular constant may be changed.

-!! -!! Constants can only be used on the right side on an assignment statement -!! (their value can not be reassigned). -!! -!! Example: -!! -!! @verbatim -!! use FMSConstantsR4, 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 FMSconstantsR4_mod - -!> @addtogroup FMSconstantsR4_mod -!> @{ -module FMSconstantsR4 - - use platform_mod, only: r4_kind, r8_kind - - !--- default scoping - implicit none - -#define RKIND r4_kind - -!--- set a default for the FMSConstantsR4 -#if !defined(GFDL_CONSTANTS) && !defined(GFS_CONSTANTS) && !defined(GEOS_CONSTANTS) -#define GFDL_CONSTANTS -#endif - -!--- perform error checking and include the correct system of constants -#if defined(GFDL_CONSTANTS) && !defined(GFS_CONSTANTS) && !defined(GEOS_CONSTANTS) -#warning "Using GFDL constantsR4" -#include -#elif !defined(GFDL_CONSTANTS) && defined(GFS_CONSTANTS) && !defined(GEOS_CONSTANTS) -#warning "Using GFS constantsR4" -#include -#elif !defined(GFDL_CONSTANTS) && !defined(GFS_CONSTANTS) && defined(GEOS_CONSTANTS) -#warning "Using GEOS constantsR4" -#include -#else -#error FATAL FMSConstantsR4 error - multiple constants macros are defined for FMS -#endif - - !--- public interfaces - public :: FMSConstantsR4_init - - contains - - !> @brief FMSconstantsR4 init routine - subroutine FMSconstantsR4_init - use mpp_mod, only: stdlog - integer :: logunit - logunit = stdlog() - - write (logunit,'(/,80("="),/(a))') trim(constantsR4_version) - - end subroutine FMSconstantsR4_init - -end module FMSconstantsR4 -!> @} -! close documentation grouping diff --git a/constants4/geos_constantsR4.h b/constants4/geos_constantsR4.h deleted file mode 100644 index a2b719b29e..0000000000 --- a/constants4/geos_constantsR4.h +++ /dev/null @@ -1,97 +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 . -!*********************************************************************** - -character(len=20), public, parameter :: constantsR4_version = 'FMSConstantsR4: GEOS' - -!--- temporary definition for backwards compatibility -real(kind=RKIND), public, parameter :: small_fac = 1._r8_kind - -!--- Spherical coordinate conversion constants -real(kind=r8_kind), public, parameter :: PI_8 = 3.14159265358979323846_r8_kind !< Ratio of circle circumference to diameter [N/A] -real(kind=RKIND), public, parameter :: PI = PI_8 !< Ratio of circle circumference to diameter [N/A] -real(kind=RKIND), public, parameter :: RAD_TO_DEG = 180._r8_kind/PI_8 !< Degrees per radian [deg/rad] -real(kind=RKIND), public, parameter :: DEG_TO_RAD = PI_8/180._r8_kind !< Radians per degree [rad/deg] -real(kind=RKIND), public, parameter :: RADIAN = RAD_TO_DEG !< Equal to RAD_TO_DEG for backward compatability. [rad/deg] - -!--- Earth physical constants -real(kind=RKIND), public, parameter :: RADIUS = 6371.0E3_r8_kind !< Radius of the Earth [m] -real(kind=RKIND), public, parameter :: OMEGA = 2.0*PI_8/86164.0 !< Rotation rate of the Earth [1/s] -real(kind=RKIND), public, parameter :: GRAV = 9.80665_r8_kind !< Acceleration due to gravity [m/s^2] -real(kind=RKIND), public, parameter :: SECONDS_PER_DAY = 86400._r8_kind !< Seconds in a day [s] -real(kind=RKIND), public, parameter :: SECONDS_PER_HOUR = 3600._r8_kind !< Seconds in an hour [s] -real(kind=RKIND), public, parameter :: SECONDS_PER_MINUTE = 60._r8_kind !< Seconds in a minute [s] - -!--- Various gas constants -real(kind=RKIND), public, parameter :: RDGAS = 8314.47 /28.965 !< Gas constant for dry air [J/kg/deg] -real(kind=RKIND), public, parameter :: RVGAS = 8314.47 /18.015 !< Gas constant for water vapor [J/kg/deg] -real(kind=RKIND), public, parameter :: HLV = 2.4665E6_r8_kind !< Latent heat of evaporation [J/kg] -real(kind=RKIND), public, parameter :: HLF = 3.3370E5_r8_kind !< Latent heat of fusion [J/kg] -real(kind=RKIND), public, parameter :: HLS = HLV + HLF !< Latent heat of sublimation [J/kg] -real(kind=RKIND), public, parameter :: KAPPA = RDGAS/(3.5*RDGAS) !< RDGAS / (3.5*RDGAS) [dimensionless] -real(kind=RKIND), public, parameter :: CP_AIR = RDGAS/KAPPA !< Specific heat capacity of dry air - !! at constant pressure [J/kg/deg] -real(kind=RKIND), public, parameter :: CP_VAPOR = 4.0_r8_kind*RVGAS !< Specific heat capacity of water vapor - !! at constant pressure [J/kg/deg] -real(kind=RKIND), public, parameter :: CP_OCEAN = 3989.24495292815_r8_kind !< Specific heat capacity taken from McDougall (2002) - !! "Potential Enthalpy ..." [J/kg/deg] -real(kind=RKIND), public, parameter :: DENS_H2O = 1000._r8_kind !< Density of liquid water [kg/m^3] -real(kind=RKIND), public, parameter :: RHOAIR = 1.292269_r8_kind !< Reference atmospheric density [kg/m^3] -real(kind=RKIND), public, parameter :: RHO0 = 1.035E3_r8_kind !< Average density of sea water [kg/m^3] -real(kind=RKIND), public, parameter :: RHO0R = 1.0_r8_kind/RHO0 !< Reciprocal of average density of sea water [m^3/kg] -real(kind=RKIND), 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(kind=RKIND), public, parameter :: O2MIXRAT = 2.0953E-01_r8_kind !< Mixing ratio of molecular oxygen in air [dimensionless] -real(kind=RKIND), public, parameter :: WTMAIR = 2.896440E+01_r8_kind !< Molecular weight of air [AMU] -real(kind=RKIND), public, parameter :: WTMH2O = WTMAIR*(RDGAS/RVGAS) !< Molecular weight of water [AMU] -real(kind=RKIND), public, parameter :: WTMOZONE = 47.99820_r8_kind !< Molecular weight of ozone [AMU] -real(kind=RKIND), public, parameter :: WTMC = 12.00000_r8_kind !< Molecular weight of carbon [AMU] -real(kind=RKIND), public, parameter :: WTMCO2 = 44.00995_r8_kind !< Molecular weight of carbon dioxide [AMU] -real(kind=RKIND), public, parameter :: WTMCH4 = 16.0425_r8_kind !< Molecular weight of methane [AMU] -real(kind=RKIND), public, parameter :: WTMO2 = 31.9988_r8_kind !< Molecular weight of molecular oxygen [AMU] -real(kind=RKIND), public, parameter :: WTMCFC11 = 137.3681_r8_kind !< Molecular weight of CFC-11 (CCl3F) [AMU] -real(kind=RKIND), public, parameter :: WTMCFC12 = 120.9135_r8_kind !< Molecular weight of CFC-21 (CCl2F2) [AMU] -real(kind=RKIND), public, parameter :: WTMN = 14.0067_r8_kind !< Molecular weight of Nitrogen [AMU] -real(kind=RKIND), public, parameter :: DIFFAC = 1.660_r8_kind !< Diffusivity factor [dimensionless] -real(kind=RKIND), public, parameter :: ES0 = 1.0_r8_kind !< Humidity factor [dimensionless] - !! Controls the humidity content of the atmosphere through - !! the Saturation Vapour Pressure expression - !! when using DO_SIMPLE - -!--- Pressure and Temperature constants -real(kind=RKIND), public, parameter :: PSTD = 1.013250E+06_r8_kind !< Mean sea level pressure [dynes/cm^2] -real(kind=RKIND), public, parameter :: PSTD_MKS = 101325.0_r8_kind !< Mean sea level pressure [N/m^2] -real(kind=RKIND), public, parameter :: KELVIN = 273.16_r8_kind !< Degrees Kelvin at zero Celsius [K] -real(kind=RKIND), public, parameter :: TFREEZE = 273.16_r8_kind !< Freezing temperature of fresh water [K] -real(kind=RKIND), 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] - -!--- Named constants -real(kind=RKIND), public, parameter :: STEFAN = 5.6734E-8_r8_kind !< Stefan-Boltzmann constant [W/m^2/deg^4] -real(kind=RKIND), public, parameter :: AVOGNO = 6.023000E+23_r8_kind !< Avogadro's number [atoms/mole] -real(kind=RKIND), public, parameter :: VONKARM = 0.40_r8_kind !< Von Karman constant [dimensionless] - -!--- Miscellaneous constants -real(kind=RKIND), public, parameter :: ALOGMIN = -50.0_r8_kind !< Minimum value allowed as argument to log function [N/A] -real(kind=RKIND), public, parameter :: EPSLN = 1.0E-40_r8_kind !< A small number to prevent divide by zero exceptions [N/A] -real(kind=RKIND), public, parameter :: RADCON = ((1.0E+02*GRAV)/(1.0D+04*CP_AIR))*SECONDS_PER_DAY !< Factor to convert flux divergence - !! to heating rate in degrees per day - !! [deg sec/(cm day)] -real(kind=RKIND), public, parameter :: RADCON_MKS = (GRAV/CP_AIR)*SECONDS_PER_DAY !< Factor to convert flux divergence - !! to heating rate in degrees per day - !! [deg sec/(m day)] diff --git a/constants4/gfdl_constantsR4.h b/constants4/gfdl_constantsR4.h deleted file mode 100644 index e0bd9573ba..0000000000 --- a/constants4/gfdl_constantsR4.h +++ /dev/null @@ -1,97 +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 . -!*********************************************************************** - -character(len=20), public, parameter :: constantsR4_version = 'FMSConstantsR4: GFDL' - -!--- temporary definition for backwards compatibility -real(kind=RKIND), public, parameter :: small_fac = 1._r8_kind - -!--- Spherical coordinate conversion constants -real(kind=r8_kind), public, parameter :: PI_8 = 3.14159265358979323846_r8_kind !< Ratio of circle circumference to diameter [N/A] -real(kind=RKIND), public, parameter :: PI = PI_8 !< Ratio of circle circumference to diameter [N/A] -real(kind=RKIND), public, parameter :: RAD_TO_DEG = 180._r8_kind/PI_8 !< Degrees per radian [deg/rad] -real(kind=RKIND), public, parameter :: DEG_TO_RAD = PI_8/180._r8_kind !< Radians per degree [rad/deg] -real(kind=RKIND), public, parameter :: RADIAN = RAD_TO_DEG !< Equal to RAD_TO_DEG for backward compatability. [rad/deg] - -!--- Earth physical constants -real(kind=RKIND), public, parameter :: RADIUS = 6371.0E+3_r8_kind !< Radius of the Earth [m] -real(kind=RKIND), public, parameter :: OMEGA = 7.292E-5_r8_kind !< Rotation rate of the Earth [1/s] -real(kind=RKIND), public, parameter :: GRAV = 9.80_r8_kind !< Acceleration due to gravity [m/s^2] -real(kind=RKIND), public, parameter :: SECONDS_PER_DAY = 86400._r8_kind !< Seconds in a day [s] -real(kind=RKIND), public, parameter :: SECONDS_PER_HOUR = 3600._r8_kind !< Seconds in an hour [s] -real(kind=RKIND), public, parameter :: SECONDS_PER_MINUTE = 60._r8_kind !< Seconds in a minute [s] - -!--- Various gas constants -real(kind=RKIND), public, parameter :: RDGAS = 287.04_r8_kind !< Gas constant for dry air [J/kg/deg] -real(kind=RKIND), public, parameter :: RVGAS = 461.50_r8_kind !< Gas constant for water vapor [J/kg/deg] -real(kind=RKIND), public, parameter :: HLV = 2.500E6_r8_kind !< Latent heat of evaporation [J/kg] -real(kind=RKIND), public, parameter :: HLF = 3.34E5_r8_kind !< Latent heat of fusion [J/kg] -real(kind=RKIND), public, parameter :: HLS = HLV + HLF !< Latent heat of sublimation [J/kg] -real(kind=RKIND), public, parameter :: KAPPA = 2.0_r8_kind/7.0_r8_kind !< RDGAS / CP_AIR [dimensionless] -real(kind=RKIND), public, parameter :: CP_AIR = RDGAS/KAPPA !< Specific heat capacity of dry air - !! at constant pressure [J/kg/deg] -real(kind=RKIND), public, parameter :: CP_VAPOR = 4.0_r8_kind*RVGAS !< Specific heat capacity of water vapor - !! at constant pressure [J/kg/deg] -real(kind=RKIND), public, parameter :: CP_OCEAN = 3989.24495292815_r8_kind !< Specific heat capacity taken from McDougall (2002) - !! "Potential Enthalpy ..." [J/kg/deg] -real(kind=RKIND), public, parameter :: DENS_H2O = 1000._r8_kind !< Density of liquid water [kg/m^3] -real(kind=RKIND), public, parameter :: RHOAIR = 1.292269_r8_kind !< Reference atmospheric density [kg/m^3] -real(kind=RKIND), public, parameter :: RHO0 = 1.035E3_r8_kind !< Average density of sea water [kg/m^3] -real(kind=RKIND), public, parameter :: RHO0R = 1.0_r8_kind/RHO0 !< Reciprocal of average density of sea water [m^3/kg] -real(kind=RKIND), 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(kind=RKIND), public, parameter :: O2MIXRAT = 2.0953E-01_r8_kind !< Mixing ratio of molecular oxygen in air [dimensionless] -real(kind=RKIND), public, parameter :: WTMAIR = 2.896440E+01_r8_kind !< Molecular weight of air [AMU] -real(kind=RKIND), public, parameter :: WTMH2O = WTMAIR*(RDGAS/RVGAS) !< Molecular weight of water [AMU] -real(kind=RKIND), public, parameter :: WTMOZONE = 47.99820_r8_kind !< Molecular weight of ozone [AMU] -real(kind=RKIND), public, parameter :: WTMC = 12.00000_r8_kind !< Molecular weight of carbon [AMU] -real(kind=RKIND), public, parameter :: WTMCO2 = 44.00995_r8_kind !< Molecular weight of carbon dioxide [AMU] -real(kind=RKIND), public, parameter :: WTMCH4 = 16.0425_r8_kind !< Molecular weight of methane [AMU] -real(kind=RKIND), public, parameter :: WTMO2 = 31.9988_r8_kind !< Molecular weight of molecular oxygen [AMU] -real(kind=RKIND), public, parameter :: WTMCFC11 = 137.3681_r8_kind !< Molecular weight of CFC-11 (CCl3F) [AMU] -real(kind=RKIND), public, parameter :: WTMCFC12 = 120.9135_r8_kind !< Molecular weight of CFC-21 (CCl2F2) [AMU] -real(kind=RKIND), public, parameter :: WTMN = 14.0067_r8_kind !< Molecular weight of Nitrogen [AMU] -real(kind=RKIND), public, parameter :: DIFFAC = 1.660_r8_kind !< Diffusivity factor [dimensionless] -real(kind=RKIND), public, parameter :: ES0 = 1.0_r8_kind !< Humidity factor [dimensionless] - !! Controls the humidity content of the atmosphere through - !! the Saturation Vapour Pressure expression - !! when using DO_SIMPLE - -!--- Pressure and Temperature constants -real(kind=RKIND), public, parameter :: PSTD = 1.013250E+06_r8_kind !< Mean sea level pressure [dynes/cm^2] -real(kind=RKIND), public, parameter :: PSTD_MKS = 101325.0_r8_kind !< Mean sea level pressure [N/m^2] -real(kind=RKIND), public, parameter :: KELVIN = 273.15_r8_kind !< Degrees Kelvin at zero Celsius [K] -real(kind=RKIND), public, parameter :: TFREEZE = 273.16_r8_kind !< Freezing temperature of fresh water [K] -real(kind=RKIND), 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] - -!--- Named constants -real(kind=RKIND), public, parameter :: STEFAN = 5.6734E-8_r8_kind !< Stefan-Boltzmann constant [W/m^2/deg^4] -real(kind=RKIND), public, parameter :: AVOGNO = 6.023000E+23_r8_kind !< Avogadro's number [atoms/mole] -real(kind=RKIND), public, parameter :: VONKARM = 0.40_r8_kind !< Von Karman constant [dimensionless] - -!--- Miscellaneous constants -real(kind=RKIND), public, parameter :: ALOGMIN = -50.0_r8_kind !< Minimum value allowed as argument to log function [N/A] -real(kind=RKIND), public, parameter :: EPSLN = 1.0E-40_r8_kind !< A small number to prevent divide by zero exceptions [N/A] -real(kind=RKIND), public, parameter :: RADCON = ((1.0E+02*GRAV)/(1.0D+04*CP_AIR))*SECONDS_PER_DAY !< Factor to convert flux divergence - !! to heating rate in degrees per day - !! [deg sec/(cm day)] -real(kind=RKIND), public, parameter :: RADCON_MKS = (GRAV/CP_AIR)*SECONDS_PER_DAY !< Factor to convert flux divergence - !! to heating rate in degrees per day - !! [deg sec/(m day)] diff --git a/constants4/gfs_constantsR4.h b/constants4/gfs_constantsR4.h deleted file mode 100644 index 04da7b0014..0000000000 --- a/constants4/gfs_constantsR4.h +++ /dev/null @@ -1,100 +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 . -!*********************************************************************** - -character(len=20), public, parameter :: constantsR4_version = 'FMSConstantsR4: GFS ' - -!--- temporary definition for backwards compatibility -real(kind=RKIND), public, parameter :: small_fac = 1._r8_kind - -!--- Spherical coordinate conversion constants -real(kind=r8_kind), public, parameter :: PI_8 = 3.1415926535897931_r8_kind !< Ratio of circle circumference to diameter [N/A] -real(kind=RKIND), public, parameter :: PI = PI_8 !< Ratio of circle circumference to diameter [N/A] -real(kind=RKIND), public, parameter :: RAD_TO_DEG = 180._r8_kind/PI_8 !< Degrees per radian [deg/rad] -real(kind=RKIND), public, parameter :: DEG_TO_RAD = PI_8/180._r8_kind !< Radians per degree [rad/deg] -real(kind=RKIND), public, parameter :: RADIAN = RAD_TO_DEG !< Equal to RAD_TO_DEG for backward compatability. [rad/deg] - -!--- Earth physical constants -real(kind=RKIND), public, parameter :: RADIUS = 6.3712E+6_r8_kind !< Radius of the Earth [m] -real(kind=RKIND), public, parameter :: OMEGA = 7.2921E-5_r8_kind !< Rotation rate of the Earth [1/s] -real(kind=r8_kind), public, parameter :: GRAV_8 = 9.80665_r8_kind !< Acceleration due to gravity [m/s^2] (REAL(KIND=8)) -real(kind=RKIND), public, parameter :: GRAV = GRAV_8 !< Acceleration due to gravity [m/s^2] -real(kind=RKIND), public, parameter :: SECONDS_PER_DAY = 86400._r8_kind !< Seconds in a day [s] -real(kind=RKIND), public, parameter :: SECONDS_PER_HOUR = 3600._r8_kind !< Seconds in an hour [s] -real(kind=RKIND), public, parameter :: SECONDS_PER_MINUTE = 60._r8_kind !< Seconds in a minute [s] - -!--- Various gas constants -real(kind=RKIND), public, parameter :: RDGAS = 287.05_r8_kind !< Gas constant for dry air [J/kg/deg] -real(kind=RKIND), public, parameter :: RVGAS = 461.50_r8_kind !< Gas constant for water vapor [J/kg/deg] -real(kind=RKIND), public, parameter :: HLV = 2.500E6_r8_kind !< Latent heat of evaporation [J/kg] -real(kind=RKIND), public, parameter :: HLF = 3.3358e5_r8_kind !< Latent heat of fusion [J/kg] -real(kind=RKIND), public, parameter :: HLS = HLV + HLF !< Latent heat of sublimation [J/kg] -real(kind=RKIND), public, parameter :: CP_AIR = 1004.6_r8_kind !< Specific heat capacity of dry air - !! at constant pressure [J/kg/deg] -real(kind=RKIND), public, parameter :: CP_VAPOR = 4.0_r8_kind*RVGAS !< Specific heat capacity of water vapor - !! at constant pressure [J/kg/deg] -real(kind=RKIND), public, parameter :: CP_OCEAN = 3989.24495292815_r8_kind !< Specific heat capacity taken from McDougall (2002) - !! "Potential Enthalpy ..." [J/kg/deg] -real(kind=RKIND), public, parameter :: KAPPA = RDGAS/CP_AIR !< RDGAS / CP_AIR [dimensionless] -real(kind=RKIND), public, parameter :: DENS_H2O = 1000._r8_kind !< Density of liquid water [kg/m^3] -real(kind=RKIND), public, parameter :: RHOAIR = 1.292269_r8_kind !< Reference atmospheric density [kg/m^3] -real(kind=RKIND), public, parameter :: RHO0 = 1.035E3_r8_kind !< Average density of sea water [kg/m^3] -real(kind=RKIND), public, parameter :: RHO0R = 1.0_r8_kind/RHO0 !< Reciprocal of average density of sea water [m^3/kg] -real(kind=RKIND), 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(kind=RKIND), public, parameter :: O2MIXRAT = 2.0953E-01_r8_kind !< Mixing ratio of molecular oxygen in air [dimensionless] -real(kind=RKIND), public, parameter :: WTMAIR = 2.896440E+01_r8_kind !< Molecular weight of air [AMU] -real(kind=RKIND), public, parameter :: WTMH2O = WTMAIR*(RDGAS/RVGAS) !< Molecular weight of water [AMU] -real(kind=RKIND), public, parameter :: WTMOZONE = 47.99820_r8_kind !< Molecular weight of ozone [AMU] -real(kind=RKIND), public, parameter :: WTMC = 12.00000_r8_kind !< Molecular weight of carbon [AMU] -real(kind=RKIND), public, parameter :: WTMCO2 = 44.00995_r8_kind !< Molecular weight of carbon dioxide [AMU] -real(kind=RKIND), public, parameter :: WTMCH4 = 16.0425_r8_kind !< Molecular weight of methane [AMU] -real(kind=RKIND), public, parameter :: WTMO2 = 31.9988_r8_kind !< Molecular weight of molecular oxygen [AMU] -real(kind=RKIND), public, parameter :: WTMCFC11 = 137.3681_r8_kind !< Molecular weight of CFC-11 (CCl3F) [AMU] -real(kind=RKIND), public, parameter :: WTMCFC12 = 120.9135_r8_kind !< Molecular weight of CFC-21 (CCl2F2) [AMU] -real(kind=RKIND), public, parameter :: WTMN = 14.0067_r8_kind !< Molecular weight of Nitrogen [AMU] -real(kind=RKIND), public, parameter :: DIFFAC = 1.660_r8_kind !< Diffusivity factor [dimensionless] -real(kind=RKIND), public, parameter :: ES0 = 1.0_r8_kind !< Humidity factor [dimensionless] - !! Controls the humidity content of the atmosphere through - !! the Saturation Vapour Pressure expression - !! when using DO_SIMPLE -real(kind=RKIND), public, parameter :: CON_CLIQ = 4.1855E+3_r8_kind !< Specific heat H2O liq [J/kg/K] -real(kind=RKIND), public, parameter :: CON_CSOL = 2.1060E+3_r8_kind !< Specific heat H2O ice [J/kg/K] - -!--- Pressure and Temperature constants -real(kind=RKIND), public, parameter :: PSTD = 1.013250E+06_r8_kind !< Mean sea level pressure [dynes/cm^2] -real(kind=RKIND), public, parameter :: PSTD_MKS = 101325.0_r8_kind !< Mean sea level pressure [N/m^2] -real(kind=RKIND), public, parameter :: KELVIN = 273.15_r8_kind !< Degrees Kelvin at zero Celsius [K] -real(kind=RKIND), public, parameter :: TFREEZE = 273.15_r8_kind !< Freezing temperature of fresh water [K] -real(kind=RKIND), 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] - -!--- Named constants -real(kind=RKIND), public, parameter :: STEFAN = 5.6734E-8_r8_kind !< Stefan-Boltzmann constant [W/m^2/deg^4] -real(kind=RKIND), public, parameter :: AVOGNO = 6.023000E+23_r8_kind !< Avogadro's number [atoms/mole] -real(kind=RKIND), public, parameter :: VONKARM = 0.40_r8_kind !< Von Karman constant [dimensionless] - -!--- Miscellaneous constants -real(kind=RKIND), public, parameter :: ALOGMIN = -50.0_r8_kind !< Minimum value allowed as argument to log function [N/A] -real(kind=RKIND), public, parameter :: EPSLN = 1.0E-40_r8_kind !< A small number to prevent divide by zero exceptions [N/A] -real(kind=RKIND), public, parameter :: RADCON = ((1.0D+02*GRAV)/(1.0D+04*CP_AIR))*SECONDS_PER_DAY !< Factor to convert flux divergence - !! to heating rate in degrees per day - !! [deg sec/(cm day)] -real(kind=RKIND), public, parameter :: RADCON_MKS = (GRAV/CP_AIR)*SECONDS_PER_DAY !< Factor to convert flux divergence - !! to heating rate in degrees per day - !! [deg sec/(m day)] diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index 96221aee36..4519f7f82c 100644 --- a/diag_manager/diag_axis.F90 +++ b/diag_manager/diag_axis.F90 @@ -110,7 +110,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. @@ -228,15 +228,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 @@ -465,7 +457,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 @@ -486,15 +478,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 d9a7c8aa40..39f9a8a0e9 100644 --- a/diag_manager/diag_grid.F90 +++ b/diag_manager/diag_grid.F90 @@ -130,10 +130,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 @@ -252,67 +252,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 01f0ad6f8b..4660e282f8 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -342,6 +342,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 @@ -381,8 +387,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 @@ -390,14 +396,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, & @@ -419,8 +417,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 @@ -456,14 +453,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,& @@ -613,8 +602,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 @@ -627,8 +616,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 @@ -647,15 +635,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 @@ -683,14 +663,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 @@ -810,18 +782,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. @@ -1287,45 +1250,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 @@ -1334,15 +1287,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 @@ -1351,18 +1296,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,& @@ -1385,16 +1319,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 @@ -1403,15 +1337,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 @@ -1420,18 +1346,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) @@ -1441,16 +1356,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 @@ -1484,8 +1551,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. @@ -1508,23 +1573,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 @@ -1538,18 +1586,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) @@ -1565,7 +1602,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 @@ -1573,7 +1609,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 @@ -1582,7 +1617,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 @@ -1590,7 +1624,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 @@ -1616,8 +1649,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & twohi = n1-(ie-is+1) IF ( MOD(twohi,2) /= 0 ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in first dimension', & - & err_msg) ) THEN - DEALLOCATE(field_out) + & err_msg) ) THEN DEALLOCATE(oor_mask) RETURN END IF @@ -1625,8 +1657,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & twohj = n2-(je-js+1) IF ( MOD(twohj,2) /= 0 ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in second dimension', & - & err_msg) ) THEN - DEALLOCATE(field_out) + & err_msg) ) THEN DEALLOCATE(oor_mask) RETURN END IF @@ -1651,15 +1682,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 @@ -1688,13 +1711,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 @@ -1711,8 +1734,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 [,]. @@ -1762,7 +1785,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. @@ -1807,7 +1830,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 @@ -1820,7 +1842,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 @@ -1840,7 +1861,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 @@ -1852,7 +1872,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 @@ -1867,7 +1886,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 @@ -1883,7 +1901,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 @@ -1898,7 +1915,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 @@ -1914,11 +1930,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 @@ -1934,11 +1950,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 @@ -1958,11 +1974,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 @@ -1978,11 +1994,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 @@ -1999,7 +2015,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 @@ -2010,7 +2025,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 @@ -2032,11 +2046,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 @@ -2059,11 +2073,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 @@ -2095,11 +2109,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 @@ -2117,11 +2131,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 @@ -2137,7 +2151,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 @@ -2151,11 +2164,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 @@ -2172,11 +2185,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 @@ -2222,12 +2235,12 @@ 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,:,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 - END IF + & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + END IF END IF END DO END DO @@ -2242,12 +2255,12 @@ 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,:,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 - END IF + & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + END IF END IF END DO END DO @@ -2272,11 +2285,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 @@ -2285,11 +2298,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 @@ -2299,7 +2312,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 @@ -2309,22 +2321,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 @@ -2346,15 +2358,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & 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 @@ -2373,15 +2385,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & 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 @@ -2406,7 +2418,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 @@ -2424,15 +2436,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 @@ -2448,15 +2460,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 @@ -2471,7 +2483,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 @@ -2486,7 +2498,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 @@ -2496,15 +2507,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 @@ -2517,15 +2528,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 @@ -2539,7 +2550,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 @@ -2561,12 +2572,12 @@ 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,:,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 - END IF + & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + END IF END IF END DO END DO @@ -2581,12 +2592,12 @@ 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,:,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 - END IF + & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + END IF END IF END DO END DO @@ -2612,22 +2623,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 @@ -2637,7 +2648,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 @@ -2647,22 +2657,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 @@ -2694,9 +2704,9 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & j <= l_end(2)+hj ) THEN 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) + IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND.& + & field(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample)) THEN + output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k) END IF END IF END DO @@ -2706,24 +2716,23 @@ 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 ( 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) + WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. & + & field(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample))& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker) 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) + WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND.& + & field(f1:f2,f3:f4,ks:ke)>output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample))& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke) END IF ELSE IF ( need_compute ) THEN @@ -2735,8 +2744,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & 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 @@ -2746,24 +2755,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 @@ -2778,9 +2784,9 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & j <= l_end(2)+hj ) THEN 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) + IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND.& + & field(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN + output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k) END IF END IF END DO @@ -2790,24 +2796,23 @@ 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 ( 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) + WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND.& + & field(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample)) & + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker) 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) + WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND.& + & field(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample))& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke) END IF ELSE IF ( need_compute ) THEN @@ -2818,9 +2823,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 @@ -2830,24 +2834,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 @@ -2865,7 +2866,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 @@ -2877,14 +2878,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 @@ -2893,7 +2893,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 @@ -2906,7 +2906,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 @@ -2916,14 +2916,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 @@ -2931,7 +2930,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 @@ -2943,8 +2942,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 @@ -2952,20 +2950,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 @@ -3013,7 +3010,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 @@ -3023,99 +3019,46 @@ 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 - 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 + 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 - 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 a676fefede..ee08cdd5f5 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -628,8 +628,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 @@ -639,20 +639,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) @@ -674,33 +664,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 1e29b8bc38..e2e193cae8 100644 --- a/sat_vapor_pres/sat_vapor_pres.F90 +++ b/sat_vapor_pres/sat_vapor_pres.F90 @@ -191,8 +191,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 @@ -738,8 +736,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 @@ -770,8 +768,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 @@ -806,8 +804,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 @@ -842,8 +840,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 @@ -1974,10 +1972,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 @@ -2032,11 +2030,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 @@ -2094,11 +2092,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 @@ -2155,11 +2153,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 @@ -2607,247 +2605,132 @@ 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 b8ceabfb2b..034bf0f7ed 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -47,9 +47,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 @@ -475,330 +472,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 @@ -807,326 +559,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 @@ -1135,322 +644,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 @@ -1459,298 +727,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 !####################################################################### @@ -2096,295 +1145,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 @@ -2392,763 +1253,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 @@ -3156,468 +1543,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 - - 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 + 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 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 @@ -3626,295 +1727,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 @@ -3922,468 +1835,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 aab4822994..6346ff9a23 100644 --- a/time_manager/time_manager.F90 +++ b/time_manager/time_manager.F90 @@ -63,7 +63,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 @@ -1180,7 +1180,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 @@ -1191,29 +1191,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 a89af948bd..5c2321fce4 100644 --- a/tracer_manager/tracer_manager.F90 +++ b/tracer_manager/tracer_manager.F90 @@ -73,8 +73,6 @@ module tracer_manager_mod fm_exists, & MODEL_NAMES -use platform_mod, only: r4_kind, r8_kind - implicit none private @@ -1036,7 +1034,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 @@ -1062,15 +1060,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 @@ -1079,15 +1069,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,38 +1103,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 From 95287f55ef701bf64b13ee9d61820eaccab7f7cf Mon Sep 17 00:00:00 2001 From: rem1776 Date: Wed, 23 Nov 2022 15:05:59 -0500 Subject: [PATCH 02/53] Add back in constants4 files from emc revert --- constants4/constantsr4.F90 | 33 +++++++++++ constants4/fmsconstantsr4.F90 | 99 +++++++++++++++++++++++++++++++++ constants4/geos_constantsR4.h | 97 +++++++++++++++++++++++++++++++++ constants4/gfdl_constantsR4.h | 97 +++++++++++++++++++++++++++++++++ constants4/gfs_constantsR4.h | 100 ++++++++++++++++++++++++++++++++++ 5 files changed, 426 insertions(+) create mode 100644 constants4/constantsr4.F90 create mode 100644 constants4/fmsconstantsr4.F90 create mode 100644 constants4/geos_constantsR4.h create mode 100644 constants4/gfdl_constantsR4.h create mode 100644 constants4/gfs_constantsR4.h diff --git a/constants4/constantsr4.F90 b/constants4/constantsr4.F90 new file mode 100644 index 0000000000..78c4da27a4 --- /dev/null +++ b/constants4/constantsr4.F90 @@ -0,0 +1,33 @@ +!*********************************************************************** +!* 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 constantsR4_mod constantsR4_mod +!> @ingroup constantsR4 +!> @brief compatibility module as we transition to an FMSConstantsR4 module +!! +!> @file +!> @brief File for @ref constantsR4_mod + +module constantsR4_mod + +!> rename to not conflict with any other version vars +use FMSConstantsR4, version => constantsR4_version, constants_init => FMSconstantsR4_init + +contains + +end module constantsR4_mod diff --git a/constants4/fmsconstantsr4.F90 b/constants4/fmsconstantsr4.F90 new file mode 100644 index 0000000000..76267101d6 --- /dev/null +++ b/constants4/fmsconstantsr4.F90 @@ -0,0 +1,99 @@ +!*********************************************************************** +!* 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 fmsconstantsR4 FMSConstantsR4 +!> @ingroup libfms +!> @brief Defines useful constants for Earth. Constants are defined as real +!! +!> FMSconstantsR4 have been declared as r4_kind or r8_kind PARAMETER. +!! +!! The value of a constant defined and used from here cannot be changed +!! in a users program. New constants can be defined in terms of values +!! from the FMSconstants module and their includes using a parameter +!! statement.

+!! +!! The currently support contant systems are: +!! GFDL constants (gfdl_constantsR4.h) +!! GEOS constants (geos_constantsR4.h) +!! GFS constants (gfs_constantsR4.h) +!!

+!! +!! The name given to a particular constant may be changed.

+!! +!! Constants can only be used on the right side on an assignment statement +!! (their value can not be reassigned). +!! +!! Example: +!! +!! @verbatim +!! use FMSConstantsR4, 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 FMSconstantsR4_mod + +!> @addtogroup FMSconstantsR4_mod +!> @{ +module FMSconstantsR4 + + use platform_mod, only: r4_kind, r8_kind + + !--- default scoping + implicit none + +#define RKIND r4_kind + +!--- set a default for the FMSConstantsR4 +#if !defined(GFDL_CONSTANTS) && !defined(GFS_CONSTANTS) && !defined(GEOS_CONSTANTS) +#define GFDL_CONSTANTS +#endif + +!--- perform error checking and include the correct system of constants +#if defined(GFDL_CONSTANTS) && !defined(GFS_CONSTANTS) && !defined(GEOS_CONSTANTS) +#warning "Using GFDL constantsR4" +#include +#elif !defined(GFDL_CONSTANTS) && defined(GFS_CONSTANTS) && !defined(GEOS_CONSTANTS) +#warning "Using GFS constantsR4" +#include +#elif !defined(GFDL_CONSTANTS) && !defined(GFS_CONSTANTS) && defined(GEOS_CONSTANTS) +#warning "Using GEOS constantsR4" +#include +#else +#error FATAL FMSConstantsR4 error - multiple constants macros are defined for FMS +#endif + + !--- public interfaces + public :: FMSConstantsR4_init + + contains + + !> @brief FMSconstantsR4 init routine + subroutine FMSconstantsR4_init + use mpp_mod, only: stdlog + integer :: logunit + logunit = stdlog() + + write (logunit,'(/,80("="),/(a))') trim(constantsR4_version) + + end subroutine FMSconstantsR4_init + +end module FMSconstantsR4 +!> @} +! close documentation grouping diff --git a/constants4/geos_constantsR4.h b/constants4/geos_constantsR4.h new file mode 100644 index 0000000000..a2b719b29e --- /dev/null +++ b/constants4/geos_constantsR4.h @@ -0,0 +1,97 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +character(len=20), public, parameter :: constantsR4_version = 'FMSConstantsR4: GEOS' + +!--- temporary definition for backwards compatibility +real(kind=RKIND), public, parameter :: small_fac = 1._r8_kind + +!--- Spherical coordinate conversion constants +real(kind=r8_kind), public, parameter :: PI_8 = 3.14159265358979323846_r8_kind !< Ratio of circle circumference to diameter [N/A] +real(kind=RKIND), public, parameter :: PI = PI_8 !< Ratio of circle circumference to diameter [N/A] +real(kind=RKIND), public, parameter :: RAD_TO_DEG = 180._r8_kind/PI_8 !< Degrees per radian [deg/rad] +real(kind=RKIND), public, parameter :: DEG_TO_RAD = PI_8/180._r8_kind !< Radians per degree [rad/deg] +real(kind=RKIND), public, parameter :: RADIAN = RAD_TO_DEG !< Equal to RAD_TO_DEG for backward compatability. [rad/deg] + +!--- Earth physical constants +real(kind=RKIND), public, parameter :: RADIUS = 6371.0E3_r8_kind !< Radius of the Earth [m] +real(kind=RKIND), public, parameter :: OMEGA = 2.0*PI_8/86164.0 !< Rotation rate of the Earth [1/s] +real(kind=RKIND), public, parameter :: GRAV = 9.80665_r8_kind !< Acceleration due to gravity [m/s^2] +real(kind=RKIND), public, parameter :: SECONDS_PER_DAY = 86400._r8_kind !< Seconds in a day [s] +real(kind=RKIND), public, parameter :: SECONDS_PER_HOUR = 3600._r8_kind !< Seconds in an hour [s] +real(kind=RKIND), public, parameter :: SECONDS_PER_MINUTE = 60._r8_kind !< Seconds in a minute [s] + +!--- Various gas constants +real(kind=RKIND), public, parameter :: RDGAS = 8314.47 /28.965 !< Gas constant for dry air [J/kg/deg] +real(kind=RKIND), public, parameter :: RVGAS = 8314.47 /18.015 !< Gas constant for water vapor [J/kg/deg] +real(kind=RKIND), public, parameter :: HLV = 2.4665E6_r8_kind !< Latent heat of evaporation [J/kg] +real(kind=RKIND), public, parameter :: HLF = 3.3370E5_r8_kind !< Latent heat of fusion [J/kg] +real(kind=RKIND), public, parameter :: HLS = HLV + HLF !< Latent heat of sublimation [J/kg] +real(kind=RKIND), public, parameter :: KAPPA = RDGAS/(3.5*RDGAS) !< RDGAS / (3.5*RDGAS) [dimensionless] +real(kind=RKIND), public, parameter :: CP_AIR = RDGAS/KAPPA !< Specific heat capacity of dry air + !! at constant pressure [J/kg/deg] +real(kind=RKIND), public, parameter :: CP_VAPOR = 4.0_r8_kind*RVGAS !< Specific heat capacity of water vapor + !! at constant pressure [J/kg/deg] +real(kind=RKIND), public, parameter :: CP_OCEAN = 3989.24495292815_r8_kind !< Specific heat capacity taken from McDougall (2002) + !! "Potential Enthalpy ..." [J/kg/deg] +real(kind=RKIND), public, parameter :: DENS_H2O = 1000._r8_kind !< Density of liquid water [kg/m^3] +real(kind=RKIND), public, parameter :: RHOAIR = 1.292269_r8_kind !< Reference atmospheric density [kg/m^3] +real(kind=RKIND), public, parameter :: RHO0 = 1.035E3_r8_kind !< Average density of sea water [kg/m^3] +real(kind=RKIND), public, parameter :: RHO0R = 1.0_r8_kind/RHO0 !< Reciprocal of average density of sea water [m^3/kg] +real(kind=RKIND), 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(kind=RKIND), public, parameter :: O2MIXRAT = 2.0953E-01_r8_kind !< Mixing ratio of molecular oxygen in air [dimensionless] +real(kind=RKIND), public, parameter :: WTMAIR = 2.896440E+01_r8_kind !< Molecular weight of air [AMU] +real(kind=RKIND), public, parameter :: WTMH2O = WTMAIR*(RDGAS/RVGAS) !< Molecular weight of water [AMU] +real(kind=RKIND), public, parameter :: WTMOZONE = 47.99820_r8_kind !< Molecular weight of ozone [AMU] +real(kind=RKIND), public, parameter :: WTMC = 12.00000_r8_kind !< Molecular weight of carbon [AMU] +real(kind=RKIND), public, parameter :: WTMCO2 = 44.00995_r8_kind !< Molecular weight of carbon dioxide [AMU] +real(kind=RKIND), public, parameter :: WTMCH4 = 16.0425_r8_kind !< Molecular weight of methane [AMU] +real(kind=RKIND), public, parameter :: WTMO2 = 31.9988_r8_kind !< Molecular weight of molecular oxygen [AMU] +real(kind=RKIND), public, parameter :: WTMCFC11 = 137.3681_r8_kind !< Molecular weight of CFC-11 (CCl3F) [AMU] +real(kind=RKIND), public, parameter :: WTMCFC12 = 120.9135_r8_kind !< Molecular weight of CFC-21 (CCl2F2) [AMU] +real(kind=RKIND), public, parameter :: WTMN = 14.0067_r8_kind !< Molecular weight of Nitrogen [AMU] +real(kind=RKIND), public, parameter :: DIFFAC = 1.660_r8_kind !< Diffusivity factor [dimensionless] +real(kind=RKIND), public, parameter :: ES0 = 1.0_r8_kind !< Humidity factor [dimensionless] + !! Controls the humidity content of the atmosphere through + !! the Saturation Vapour Pressure expression + !! when using DO_SIMPLE + +!--- Pressure and Temperature constants +real(kind=RKIND), public, parameter :: PSTD = 1.013250E+06_r8_kind !< Mean sea level pressure [dynes/cm^2] +real(kind=RKIND), public, parameter :: PSTD_MKS = 101325.0_r8_kind !< Mean sea level pressure [N/m^2] +real(kind=RKIND), public, parameter :: KELVIN = 273.16_r8_kind !< Degrees Kelvin at zero Celsius [K] +real(kind=RKIND), public, parameter :: TFREEZE = 273.16_r8_kind !< Freezing temperature of fresh water [K] +real(kind=RKIND), 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] + +!--- Named constants +real(kind=RKIND), public, parameter :: STEFAN = 5.6734E-8_r8_kind !< Stefan-Boltzmann constant [W/m^2/deg^4] +real(kind=RKIND), public, parameter :: AVOGNO = 6.023000E+23_r8_kind !< Avogadro's number [atoms/mole] +real(kind=RKIND), public, parameter :: VONKARM = 0.40_r8_kind !< Von Karman constant [dimensionless] + +!--- Miscellaneous constants +real(kind=RKIND), public, parameter :: ALOGMIN = -50.0_r8_kind !< Minimum value allowed as argument to log function [N/A] +real(kind=RKIND), public, parameter :: EPSLN = 1.0E-40_r8_kind !< A small number to prevent divide by zero exceptions [N/A] +real(kind=RKIND), public, parameter :: RADCON = ((1.0E+02*GRAV)/(1.0D+04*CP_AIR))*SECONDS_PER_DAY !< Factor to convert flux divergence + !! to heating rate in degrees per day + !! [deg sec/(cm day)] +real(kind=RKIND), public, parameter :: RADCON_MKS = (GRAV/CP_AIR)*SECONDS_PER_DAY !< Factor to convert flux divergence + !! to heating rate in degrees per day + !! [deg sec/(m day)] diff --git a/constants4/gfdl_constantsR4.h b/constants4/gfdl_constantsR4.h new file mode 100644 index 0000000000..e0bd9573ba --- /dev/null +++ b/constants4/gfdl_constantsR4.h @@ -0,0 +1,97 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +character(len=20), public, parameter :: constantsR4_version = 'FMSConstantsR4: GFDL' + +!--- temporary definition for backwards compatibility +real(kind=RKIND), public, parameter :: small_fac = 1._r8_kind + +!--- Spherical coordinate conversion constants +real(kind=r8_kind), public, parameter :: PI_8 = 3.14159265358979323846_r8_kind !< Ratio of circle circumference to diameter [N/A] +real(kind=RKIND), public, parameter :: PI = PI_8 !< Ratio of circle circumference to diameter [N/A] +real(kind=RKIND), public, parameter :: RAD_TO_DEG = 180._r8_kind/PI_8 !< Degrees per radian [deg/rad] +real(kind=RKIND), public, parameter :: DEG_TO_RAD = PI_8/180._r8_kind !< Radians per degree [rad/deg] +real(kind=RKIND), public, parameter :: RADIAN = RAD_TO_DEG !< Equal to RAD_TO_DEG for backward compatability. [rad/deg] + +!--- Earth physical constants +real(kind=RKIND), public, parameter :: RADIUS = 6371.0E+3_r8_kind !< Radius of the Earth [m] +real(kind=RKIND), public, parameter :: OMEGA = 7.292E-5_r8_kind !< Rotation rate of the Earth [1/s] +real(kind=RKIND), public, parameter :: GRAV = 9.80_r8_kind !< Acceleration due to gravity [m/s^2] +real(kind=RKIND), public, parameter :: SECONDS_PER_DAY = 86400._r8_kind !< Seconds in a day [s] +real(kind=RKIND), public, parameter :: SECONDS_PER_HOUR = 3600._r8_kind !< Seconds in an hour [s] +real(kind=RKIND), public, parameter :: SECONDS_PER_MINUTE = 60._r8_kind !< Seconds in a minute [s] + +!--- Various gas constants +real(kind=RKIND), public, parameter :: RDGAS = 287.04_r8_kind !< Gas constant for dry air [J/kg/deg] +real(kind=RKIND), public, parameter :: RVGAS = 461.50_r8_kind !< Gas constant for water vapor [J/kg/deg] +real(kind=RKIND), public, parameter :: HLV = 2.500E6_r8_kind !< Latent heat of evaporation [J/kg] +real(kind=RKIND), public, parameter :: HLF = 3.34E5_r8_kind !< Latent heat of fusion [J/kg] +real(kind=RKIND), public, parameter :: HLS = HLV + HLF !< Latent heat of sublimation [J/kg] +real(kind=RKIND), public, parameter :: KAPPA = 2.0_r8_kind/7.0_r8_kind !< RDGAS / CP_AIR [dimensionless] +real(kind=RKIND), public, parameter :: CP_AIR = RDGAS/KAPPA !< Specific heat capacity of dry air + !! at constant pressure [J/kg/deg] +real(kind=RKIND), public, parameter :: CP_VAPOR = 4.0_r8_kind*RVGAS !< Specific heat capacity of water vapor + !! at constant pressure [J/kg/deg] +real(kind=RKIND), public, parameter :: CP_OCEAN = 3989.24495292815_r8_kind !< Specific heat capacity taken from McDougall (2002) + !! "Potential Enthalpy ..." [J/kg/deg] +real(kind=RKIND), public, parameter :: DENS_H2O = 1000._r8_kind !< Density of liquid water [kg/m^3] +real(kind=RKIND), public, parameter :: RHOAIR = 1.292269_r8_kind !< Reference atmospheric density [kg/m^3] +real(kind=RKIND), public, parameter :: RHO0 = 1.035E3_r8_kind !< Average density of sea water [kg/m^3] +real(kind=RKIND), public, parameter :: RHO0R = 1.0_r8_kind/RHO0 !< Reciprocal of average density of sea water [m^3/kg] +real(kind=RKIND), 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(kind=RKIND), public, parameter :: O2MIXRAT = 2.0953E-01_r8_kind !< Mixing ratio of molecular oxygen in air [dimensionless] +real(kind=RKIND), public, parameter :: WTMAIR = 2.896440E+01_r8_kind !< Molecular weight of air [AMU] +real(kind=RKIND), public, parameter :: WTMH2O = WTMAIR*(RDGAS/RVGAS) !< Molecular weight of water [AMU] +real(kind=RKIND), public, parameter :: WTMOZONE = 47.99820_r8_kind !< Molecular weight of ozone [AMU] +real(kind=RKIND), public, parameter :: WTMC = 12.00000_r8_kind !< Molecular weight of carbon [AMU] +real(kind=RKIND), public, parameter :: WTMCO2 = 44.00995_r8_kind !< Molecular weight of carbon dioxide [AMU] +real(kind=RKIND), public, parameter :: WTMCH4 = 16.0425_r8_kind !< Molecular weight of methane [AMU] +real(kind=RKIND), public, parameter :: WTMO2 = 31.9988_r8_kind !< Molecular weight of molecular oxygen [AMU] +real(kind=RKIND), public, parameter :: WTMCFC11 = 137.3681_r8_kind !< Molecular weight of CFC-11 (CCl3F) [AMU] +real(kind=RKIND), public, parameter :: WTMCFC12 = 120.9135_r8_kind !< Molecular weight of CFC-21 (CCl2F2) [AMU] +real(kind=RKIND), public, parameter :: WTMN = 14.0067_r8_kind !< Molecular weight of Nitrogen [AMU] +real(kind=RKIND), public, parameter :: DIFFAC = 1.660_r8_kind !< Diffusivity factor [dimensionless] +real(kind=RKIND), public, parameter :: ES0 = 1.0_r8_kind !< Humidity factor [dimensionless] + !! Controls the humidity content of the atmosphere through + !! the Saturation Vapour Pressure expression + !! when using DO_SIMPLE + +!--- Pressure and Temperature constants +real(kind=RKIND), public, parameter :: PSTD = 1.013250E+06_r8_kind !< Mean sea level pressure [dynes/cm^2] +real(kind=RKIND), public, parameter :: PSTD_MKS = 101325.0_r8_kind !< Mean sea level pressure [N/m^2] +real(kind=RKIND), public, parameter :: KELVIN = 273.15_r8_kind !< Degrees Kelvin at zero Celsius [K] +real(kind=RKIND), public, parameter :: TFREEZE = 273.16_r8_kind !< Freezing temperature of fresh water [K] +real(kind=RKIND), 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] + +!--- Named constants +real(kind=RKIND), public, parameter :: STEFAN = 5.6734E-8_r8_kind !< Stefan-Boltzmann constant [W/m^2/deg^4] +real(kind=RKIND), public, parameter :: AVOGNO = 6.023000E+23_r8_kind !< Avogadro's number [atoms/mole] +real(kind=RKIND), public, parameter :: VONKARM = 0.40_r8_kind !< Von Karman constant [dimensionless] + +!--- Miscellaneous constants +real(kind=RKIND), public, parameter :: ALOGMIN = -50.0_r8_kind !< Minimum value allowed as argument to log function [N/A] +real(kind=RKIND), public, parameter :: EPSLN = 1.0E-40_r8_kind !< A small number to prevent divide by zero exceptions [N/A] +real(kind=RKIND), public, parameter :: RADCON = ((1.0E+02*GRAV)/(1.0D+04*CP_AIR))*SECONDS_PER_DAY !< Factor to convert flux divergence + !! to heating rate in degrees per day + !! [deg sec/(cm day)] +real(kind=RKIND), public, parameter :: RADCON_MKS = (GRAV/CP_AIR)*SECONDS_PER_DAY !< Factor to convert flux divergence + !! to heating rate in degrees per day + !! [deg sec/(m day)] diff --git a/constants4/gfs_constantsR4.h b/constants4/gfs_constantsR4.h new file mode 100644 index 0000000000..04da7b0014 --- /dev/null +++ b/constants4/gfs_constantsR4.h @@ -0,0 +1,100 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +character(len=20), public, parameter :: constantsR4_version = 'FMSConstantsR4: GFS ' + +!--- temporary definition for backwards compatibility +real(kind=RKIND), public, parameter :: small_fac = 1._r8_kind + +!--- Spherical coordinate conversion constants +real(kind=r8_kind), public, parameter :: PI_8 = 3.1415926535897931_r8_kind !< Ratio of circle circumference to diameter [N/A] +real(kind=RKIND), public, parameter :: PI = PI_8 !< Ratio of circle circumference to diameter [N/A] +real(kind=RKIND), public, parameter :: RAD_TO_DEG = 180._r8_kind/PI_8 !< Degrees per radian [deg/rad] +real(kind=RKIND), public, parameter :: DEG_TO_RAD = PI_8/180._r8_kind !< Radians per degree [rad/deg] +real(kind=RKIND), public, parameter :: RADIAN = RAD_TO_DEG !< Equal to RAD_TO_DEG for backward compatability. [rad/deg] + +!--- Earth physical constants +real(kind=RKIND), public, parameter :: RADIUS = 6.3712E+6_r8_kind !< Radius of the Earth [m] +real(kind=RKIND), public, parameter :: OMEGA = 7.2921E-5_r8_kind !< Rotation rate of the Earth [1/s] +real(kind=r8_kind), public, parameter :: GRAV_8 = 9.80665_r8_kind !< Acceleration due to gravity [m/s^2] (REAL(KIND=8)) +real(kind=RKIND), public, parameter :: GRAV = GRAV_8 !< Acceleration due to gravity [m/s^2] +real(kind=RKIND), public, parameter :: SECONDS_PER_DAY = 86400._r8_kind !< Seconds in a day [s] +real(kind=RKIND), public, parameter :: SECONDS_PER_HOUR = 3600._r8_kind !< Seconds in an hour [s] +real(kind=RKIND), public, parameter :: SECONDS_PER_MINUTE = 60._r8_kind !< Seconds in a minute [s] + +!--- Various gas constants +real(kind=RKIND), public, parameter :: RDGAS = 287.05_r8_kind !< Gas constant for dry air [J/kg/deg] +real(kind=RKIND), public, parameter :: RVGAS = 461.50_r8_kind !< Gas constant for water vapor [J/kg/deg] +real(kind=RKIND), public, parameter :: HLV = 2.500E6_r8_kind !< Latent heat of evaporation [J/kg] +real(kind=RKIND), public, parameter :: HLF = 3.3358e5_r8_kind !< Latent heat of fusion [J/kg] +real(kind=RKIND), public, parameter :: HLS = HLV + HLF !< Latent heat of sublimation [J/kg] +real(kind=RKIND), public, parameter :: CP_AIR = 1004.6_r8_kind !< Specific heat capacity of dry air + !! at constant pressure [J/kg/deg] +real(kind=RKIND), public, parameter :: CP_VAPOR = 4.0_r8_kind*RVGAS !< Specific heat capacity of water vapor + !! at constant pressure [J/kg/deg] +real(kind=RKIND), public, parameter :: CP_OCEAN = 3989.24495292815_r8_kind !< Specific heat capacity taken from McDougall (2002) + !! "Potential Enthalpy ..." [J/kg/deg] +real(kind=RKIND), public, parameter :: KAPPA = RDGAS/CP_AIR !< RDGAS / CP_AIR [dimensionless] +real(kind=RKIND), public, parameter :: DENS_H2O = 1000._r8_kind !< Density of liquid water [kg/m^3] +real(kind=RKIND), public, parameter :: RHOAIR = 1.292269_r8_kind !< Reference atmospheric density [kg/m^3] +real(kind=RKIND), public, parameter :: RHO0 = 1.035E3_r8_kind !< Average density of sea water [kg/m^3] +real(kind=RKIND), public, parameter :: RHO0R = 1.0_r8_kind/RHO0 !< Reciprocal of average density of sea water [m^3/kg] +real(kind=RKIND), 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(kind=RKIND), public, parameter :: O2MIXRAT = 2.0953E-01_r8_kind !< Mixing ratio of molecular oxygen in air [dimensionless] +real(kind=RKIND), public, parameter :: WTMAIR = 2.896440E+01_r8_kind !< Molecular weight of air [AMU] +real(kind=RKIND), public, parameter :: WTMH2O = WTMAIR*(RDGAS/RVGAS) !< Molecular weight of water [AMU] +real(kind=RKIND), public, parameter :: WTMOZONE = 47.99820_r8_kind !< Molecular weight of ozone [AMU] +real(kind=RKIND), public, parameter :: WTMC = 12.00000_r8_kind !< Molecular weight of carbon [AMU] +real(kind=RKIND), public, parameter :: WTMCO2 = 44.00995_r8_kind !< Molecular weight of carbon dioxide [AMU] +real(kind=RKIND), public, parameter :: WTMCH4 = 16.0425_r8_kind !< Molecular weight of methane [AMU] +real(kind=RKIND), public, parameter :: WTMO2 = 31.9988_r8_kind !< Molecular weight of molecular oxygen [AMU] +real(kind=RKIND), public, parameter :: WTMCFC11 = 137.3681_r8_kind !< Molecular weight of CFC-11 (CCl3F) [AMU] +real(kind=RKIND), public, parameter :: WTMCFC12 = 120.9135_r8_kind !< Molecular weight of CFC-21 (CCl2F2) [AMU] +real(kind=RKIND), public, parameter :: WTMN = 14.0067_r8_kind !< Molecular weight of Nitrogen [AMU] +real(kind=RKIND), public, parameter :: DIFFAC = 1.660_r8_kind !< Diffusivity factor [dimensionless] +real(kind=RKIND), public, parameter :: ES0 = 1.0_r8_kind !< Humidity factor [dimensionless] + !! Controls the humidity content of the atmosphere through + !! the Saturation Vapour Pressure expression + !! when using DO_SIMPLE +real(kind=RKIND), public, parameter :: CON_CLIQ = 4.1855E+3_r8_kind !< Specific heat H2O liq [J/kg/K] +real(kind=RKIND), public, parameter :: CON_CSOL = 2.1060E+3_r8_kind !< Specific heat H2O ice [J/kg/K] + +!--- Pressure and Temperature constants +real(kind=RKIND), public, parameter :: PSTD = 1.013250E+06_r8_kind !< Mean sea level pressure [dynes/cm^2] +real(kind=RKIND), public, parameter :: PSTD_MKS = 101325.0_r8_kind !< Mean sea level pressure [N/m^2] +real(kind=RKIND), public, parameter :: KELVIN = 273.15_r8_kind !< Degrees Kelvin at zero Celsius [K] +real(kind=RKIND), public, parameter :: TFREEZE = 273.15_r8_kind !< Freezing temperature of fresh water [K] +real(kind=RKIND), 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] + +!--- Named constants +real(kind=RKIND), public, parameter :: STEFAN = 5.6734E-8_r8_kind !< Stefan-Boltzmann constant [W/m^2/deg^4] +real(kind=RKIND), public, parameter :: AVOGNO = 6.023000E+23_r8_kind !< Avogadro's number [atoms/mole] +real(kind=RKIND), public, parameter :: VONKARM = 0.40_r8_kind !< Von Karman constant [dimensionless] + +!--- Miscellaneous constants +real(kind=RKIND), public, parameter :: ALOGMIN = -50.0_r8_kind !< Minimum value allowed as argument to log function [N/A] +real(kind=RKIND), public, parameter :: EPSLN = 1.0E-40_r8_kind !< A small number to prevent divide by zero exceptions [N/A] +real(kind=RKIND), public, parameter :: RADCON = ((1.0D+02*GRAV)/(1.0D+04*CP_AIR))*SECONDS_PER_DAY !< Factor to convert flux divergence + !! to heating rate in degrees per day + !! [deg sec/(cm day)] +real(kind=RKIND), public, parameter :: RADCON_MKS = (GRAV/CP_AIR)*SECONDS_PER_DAY !< Factor to convert flux divergence + !! to heating rate in degrees per day + !! [deg sec/(m day)] From 61ac8a91878ba3cd2ebda7f837e281f2862e0047 Mon Sep 17 00:00:00 2001 From: MiKyung Lee <58964324+mlee03@users.noreply.github.com> Date: Thu, 8 Dec 2022 08:30:24 -0500 Subject: [PATCH 03/53] chore: add include files for easier reviews (#1086) --- amip_interp/include/amip_interp.inc | 1563 +++++ astronomy/include/astronomy.inc | 2250 +++++++ axis_utils/include/axis_utils2.inc | 809 +++ block_control/include/block_control.inc | 260 + .../include/column_diagnostics.inc | 596 ++ coupler/include/atmos_ocean_fluxes.inc | 1233 ++++ coupler/include/coupler_types.inc | 4062 +++++++++++++ coupler/include/ensemble_manager.inc | 419 ++ data_override/include/data_override.inc | 1296 ++++ data_override/include/get_grid_version.inc | 313 + diag_integral/include/diag_integral.inc | 1500 +++++ exchange/include/stock_constants.inc | 343 ++ exchange/include/xgrid.inc | 5339 +++++++++++++++++ field_manager/include/field_manager.inc | 3851 ++++++++++++ field_manager/include/fm_util.inc | 3192 ++++++++++ fms/include/fms.inc | 862 +++ horiz_interp/include/horiz_interp.inc | 1102 ++++ horiz_interp/include/horiz_interp_bicubic.inc | 751 +++ .../include/horiz_interp_bilinear.inc | 1300 ++++ .../include/horiz_interp_conserve.inc | 1058 ++++ .../include/horiz_interp_spherical.inc | 904 +++ horiz_interp/include/horiz_interp_type.inc | 231 + interpolator/include/interpolator.inc | 3879 ++++++++++++ monin_obukhov/include/monin_obukhov.inc | 998 +++ monin_obukhov/include/monin_obukhov_inter.inc | 733 +++ mosaic2/include/grid2.inc | 1509 +++++ mosaic2/include/mosaic2.inc | 617 ++ random_numbers/include/mersennetwister.inc | 320 + random_numbers/include/random_numbers.inc | 138 + sat_vapor_pres/include/sat_vapor_pres.inc | 2849 +++++++++ sat_vapor_pres/include/sat_vapor_pres_k.inc | 2020 +++++++ time_interp/include/time_interp.inc | 971 +++ time_interp/include/time_interp_external2.inc | 1416 +++++ time_manager/include/get_cal_time.inc | 362 ++ time_manager/include/time_manager.inc | 3341 +++++++++++ topography/include/gaussian_topog.inc | 273 + topography/include/topography.inc | 974 +++ tracer_manager/include/tracer_manager.inc | 1338 +++++ tridiagonal/include/tridiagonal.inc | 173 + 39 files changed, 55145 insertions(+) create mode 100644 amip_interp/include/amip_interp.inc create mode 100644 astronomy/include/astronomy.inc create mode 100644 axis_utils/include/axis_utils2.inc create mode 100644 block_control/include/block_control.inc create mode 100644 column_diagnostics/include/column_diagnostics.inc create mode 100644 coupler/include/atmos_ocean_fluxes.inc create mode 100644 coupler/include/coupler_types.inc create mode 100644 coupler/include/ensemble_manager.inc create mode 100644 data_override/include/data_override.inc create mode 100644 data_override/include/get_grid_version.inc create mode 100644 diag_integral/include/diag_integral.inc create mode 100644 exchange/include/stock_constants.inc create mode 100644 exchange/include/xgrid.inc create mode 100644 field_manager/include/field_manager.inc create mode 100644 field_manager/include/fm_util.inc create mode 100644 fms/include/fms.inc create mode 100644 horiz_interp/include/horiz_interp.inc create mode 100644 horiz_interp/include/horiz_interp_bicubic.inc create mode 100644 horiz_interp/include/horiz_interp_bilinear.inc create mode 100644 horiz_interp/include/horiz_interp_conserve.inc create mode 100644 horiz_interp/include/horiz_interp_spherical.inc create mode 100644 horiz_interp/include/horiz_interp_type.inc create mode 100644 interpolator/include/interpolator.inc create mode 100644 monin_obukhov/include/monin_obukhov.inc create mode 100644 monin_obukhov/include/monin_obukhov_inter.inc create mode 100644 mosaic2/include/grid2.inc create mode 100644 mosaic2/include/mosaic2.inc create mode 100644 random_numbers/include/mersennetwister.inc create mode 100644 random_numbers/include/random_numbers.inc create mode 100644 sat_vapor_pres/include/sat_vapor_pres.inc create mode 100644 sat_vapor_pres/include/sat_vapor_pres_k.inc create mode 100644 time_interp/include/time_interp.inc create mode 100644 time_interp/include/time_interp_external2.inc create mode 100644 time_manager/include/get_cal_time.inc create mode 100644 time_manager/include/time_manager.inc create mode 100644 topography/include/gaussian_topog.inc create mode 100644 topography/include/topography.inc create mode 100644 tracer_manager/include/tracer_manager.inc create mode 100644 tridiagonal/include/tridiagonal.inc diff --git a/amip_interp/include/amip_interp.inc b/amip_interp/include/amip_interp.inc new file mode 100644 index 0000000000..931a16a745 --- /dev/null +++ b/amip_interp/include/amip_interp.inc @@ -0,0 +1,1563 @@ +!*********************************************************************** +!* 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 amip_interp_mod amip_interp_mod +!> @ingroup amip_interp +!> @brief Provides observed sea surface temperature and ice mask data sets that have been +!! interpolated onto your model's grid. +!! +!> @author Bruce Wyman +!! +!> When using these routines three possible data sets are available: +!! +!! 1. AMIP http://www.pcmdi.github.io/mips/amip from Jan 1979 to Jan 1989 (2 deg x 2 deg) +!! 2. Reynolds OI @ref amip_interp.rey_oi.txt from Nov 1981 to Jan 1999 (1 deg x 1 deg) +!! 3. Reynolds EOF podaac.jpl.nasa.gov/ from Jan 1950 to Dec 1998 (2 deg x 2 deg) +!! +!! All original data are observed monthly means. This module +!! interpolates linearly in time between pairs of monthly means. +!! Horizontal interpolation is done using the horiz_interp module. +!! +!! When a requested date falls outside the range of dates available +!! a namelist option allows for use of the climatological monthly +!! mean values which are computed from all of the data in a particular +!! data set. \n +!! \n AMIP 1:\n +!! from Jan 1979 to Jan 1989 (2 deg x 2 deg).\n\n +!! Reynolds OI:\n +!! from Nov 1981 to Jan 1999 (1 deg x 1 deg)\n +!! The analysis uses in situ and satellite SST's plus +!! SST's simulated by sea-ice cover.\n\n +!! Reynold's EOF:\n +!! from Jan 1950 to Dec 1998 (2 deg x 2 deg)\n +!! NCEP Reynolds Historical Reconstructed Sea Surface Temperature +!! The analysis uses both in-situ SSTs and satellite derived SSTs +!! from the NOAA Advanced Very High Resolution Radiometer. +!! In-situ data is used from 1950 to 1981, while both AVHRR derived +!! satellite SSTs and in-situ data are used from 1981 to the +!! end of 1998. +!! +!> @note The data set used by this module have been reformatted as 32-bit IEEE. +!! The data values are packed into 16-bit integers. +!! +!! The data sets are read from the following files: +!! +!! amip1 INPUT/amip1_sst.data +!! reynolds_io INPUT/reyoi_sst.data +!! reynolds_eof INPUT/reynolds_sst.data +!! +!> @var character(len=24) data_set +!! Name/type of SST data that will be used. +!! Possible values (case-insensitive) are: +!! 1) amip1 +!! 2) reynolds_eof +!! 3) reynolds_oi +!! See the @ref amip_interp_oi page for more information +!! @var character(len=16) date_out_of_range +!! Controls the use of climatological monthly mean data when +!! the requested date falls outside the range of the data set.
+!! Possible values are: +!! 
+!!   fail      - program will fail if requested date is prior
+!!               to or after the data set period.
+!!   initclimo - program uses climatological requested data is
+!!               prior to data set period and will fail if
+!!               requested date is after data set period.
+!!   climo     - program uses climatological data anytime.
+!!
+!! @var real tice_crit +!! Freezing point of sea water in degC or degK. Defaults to -1.80 +!! @var integer verbose +!! Controls printed output, 0 <= verbose <= 3, default=0 +!! additional parameters for controlling zonal prescribed sst ---- +!! these parameters only have an effect when use_zonal=.true. ---- +!! @var logical use_zonal +!! Flag to selected zonal sst or data set. Default=.false. +!! @var real teq +!! sst at the equator. Default=305 +!! @var real tdif +!! Equator to pole sst difference. Default=50 +!! @var real tann +!! Amplitude of annual cycle. Default=20 +!! @var real tlag +!! Offset for time of year (for annual cycle). Default=0.875 +!! @var integer amip_date +!! Single calendar date in integer "(year,month,day)" format +!! that is used only if set with year>0, month>0, day>0. +!! If used, model calendar date is replaced by this date, +!! but model time of day is still used to determine ice/sst. +!! Used for repeating-single-day (rsd) experiments. +!! Default=/-1,-1,-1/ +!! @var real sst_pert +!! Temperature perturbation in degrees Kelvin added onto the SST. +!! The perturbation is globally-uniform (even near sea-ice). +!! It is only used when abs(sst_pert) > 1.e-4. SST perturbation runs +!! may be useful in accessing model sensitivities. +!! Default=0. + +!> @addtogroup amip_interp_mod +!> @{ +module amip_interp_mod + +use time_interp_mod, only: time_interp, fraction_of_year + +use time_manager_mod, only: time_type, operator(+), operator(>), & + get_date, set_time, set_date + +! add by JHC +use get_cal_time_mod, only: get_cal_time + +! end add by JHC + +use horiz_interp_mod, only: horiz_interp_init, horiz_interp, & + horiz_interp_new, horiz_interp_del, & + horiz_interp_type, assignment(=) + +use fms_mod, only: error_mesg, write_version_number, & + NOTE, WARNING, FATAL, stdlog, check_nml_error, & + mpp_pe, lowercase, mpp_root_pe, & + NOTE, mpp_error, fms_error_handler + +use constants_mod, only: TFREEZE, pi +use platform_mod, only: R4_KIND, I2_KIND +use mpp_mod, only: input_nml_file +use fms2_io_mod, only: FmsNetcdfFile_t, fms2_io_file_exists=>file_exists, open_file, close_file, & + get_dimension_size, fms2_io_read_data=>read_data + +implicit none +private + +!----------------------------------------------------------------------- +!----------------- Public interfaces ----------------------------------- + +public amip_interp_init, get_amip_sst, get_amip_ice, amip_interp_new, & + amip_interp_del, amip_interp_type, assignment(=) + +!----------------------------------------------------------------------- +!----------------- Public Data ----------------------------------- +integer :: i_sst = 1200 +integer :: j_sst = 600 +real, parameter:: big_number = 1.E30 +logical :: forecast_mode = .false. +real, allocatable, dimension(:,:) :: sst_ncep, sst_anom + +public i_sst, j_sst, sst_ncep, sst_anom, forecast_mode, use_ncep_sst + +!----------------------------------------------------------------------- +!--------------------- private below here ------------------------------ + +! ---- version number ----- + +! Include variable "version" to be written to log file. +#include + + real, allocatable:: temp1(:,:), temp2(:,:) +! add by JHC + real, allocatable, dimension(:,:) :: tempamip +! end add by JHC +!----------------------------------------------------------------------- +!------ private defined data type -------- + +!> @} + +!> @brief Private data type for representing a calendar date +!> @ingroup amip_interp_mod +type date_type + sequence + integer :: year, month, day +end type + +!> Assignment overload to allow native assignment between amip_interp_type variables. +!> @ingroup amip_interp_mod +interface assignment(=) + module procedure amip_interp_type_eq +end interface + +!> Private logical equality overload for amip_interp_type +!> @ingroup amip_interp_mod +interface operator (==) + module procedure date_equals +end interface + +!> Private logical inequality overload for amip_interp_type +!> @ingroup amip_interp_mod +interface operator (/=) + module procedure date_not_equals +end interface + +!> Private logical greater than overload for amip_interp_type +!> @ingroup amip_interp_mod +interface operator (>) + module procedure date_gt +end interface + + +!> Initializes data needed for the horizontal +!! interpolation between the sst data and model grid. +!! +!> The returned variable of type amip_interp_type is needed when +!! calling get_amip_sst and get_amip_ice. +!! +!> @param lon +!! Longitude in radians of the model's grid box edges (1d lat/lon grid case) +!! or at grid box mid-point (2d case for arbitrary grids). +!> @param lat +!! Latitude in radians of the model's grid box edges (1d lat/lon grid case) +!! or at grid box mid-point (2d case for arbitrary grids). +!> @param mask +!! A mask for the model grid. +!> @param use_climo +!! Flag the specifies that monthly mean climatological values will be used. +!> @param use_annual +!! Flag the specifies that the annual mean climatological +!! will be used. If both use_annual = use_climo = true, +!! then use_annual = true will be used. +!> @param interp_method +!! specify the horiz_interp scheme. = "conservative" means conservative scheme, +!! = "bilinear" means bilinear interpolation. +!! +!> @return interp, a defined data type variable needed when calling get_amip_sst and get_amip_ice. +!! +!! \n Example usage: +!! +!! Interp = amip_interp_new ( lon, lat, mask, use_climo, use_annual, interp_method ) +!! +!! This function may be called to initialize multiple variables +!! of type amip_interp_type. However, there currently is no +!! call to release the storage used by this variable. +!! +!! The size of input augment mask must be a function of the size +!! of input augments lon and lat. The first and second dimensions +!! of mask must equal (size(lon,1)-1, size(lat,2)-1). +!! +!> @throws "FATAL: the value of the namelist parameter DATA_SET being used is not allowed" +!! Check the value of namelist variable DATA_SET. +!! +!> @throws "FATAL: requested input data set does not exist" +!! The data set requested is valid but the data does not exist in +!! the INPUT subdirectory. You may have requested amip2 data which +!! has not been officially set up. +!! See the section on DATA SETS to properly set the data up. +!! +!> @throws "FATAL: use_climo mismatch" +!! The namelist variable date_out_of_range = 'fail' and the amip_interp_new +!! argument use_climo = true. This combination is not allowed. +!! +!> @throws "FATAL: use_annual(climo) mismatch" +!! The namelist variable date_out_of_range = 'fail' and the amip_interp_new +!! argument use_annual = true. This combination is not allowed. +!! +!> @ingroup amip_interp_mod +interface amip_interp_new + module procedure amip_interp_new_1d + module procedure amip_interp_new_2d +end interface + + +!----- public data type ------ + +!> @brief Contains information needed by the interpolation module (exchange_mod) and buffers data. +!> @ingroup amip_interp_mod +type amip_interp_type + private + type (horiz_interp_type) :: Hintrp, Hintrp2 ! add by JHC + real, pointer :: data1(:,:) =>NULL(), & + data2(:,:) =>NULL() + type (date_type) :: Date1, Date2 + logical :: use_climo, use_annual + logical :: I_am_initialized=.false. +end type + +!> @addtogroup amip_interp_mod +!> @{ +!----------------------------------------------------------------------- +! ---- resolution/grid variables ---- + + integer :: mobs, nobs + real, allocatable :: lon_bnd(:), lat_bnd(:) + +! ---- global unit & date ---- + + integer, parameter :: maxc = 128 + integer :: unit + character(len=maxc) :: file_name_sst, file_name_ice + type(FmsNetcdfFile_t), target :: fileobj_sst, fileobj_ice + + type (date_type) :: Curr_date = date_type( -99, -99, -99 ) + type (date_type) :: Date_end = date_type( -99, -99, -99 ) + + real :: tice_crit_k + integer(I2_KIND) :: ice_crit + + logical :: module_is_initialized = .false. + +!----------------------------------------------------------------------- +!---- namelist ---- + + character(len=24) :: data_set = 'amip1' !< use 'amip1', 'amip2', 'reynolds_eof' + !! 'reynolds_oi', 'hurrell', or 'daily', + !! when "use_daily=.T." + ! add by JHC + + character(len=16) :: date_out_of_range = 'fail' !< use 'fail', 'initclimo', or 'climo' + + real :: tice_crit = -1.80 !< in degC or degK + integer :: verbose = 0 !< 0 <= verbose <= 3 + + logical :: use_zonal = .false. !< parameters for prescribed zonal sst option + real :: teq = 305. !< parameters for prescribed zonal sst option + real :: tdif = 50. !< parameters for prescribed zonal sst option + real :: tann = 20. !< parameters for prescribed zonal sst option + real :: tlag = 0.875 !< parameters for prescribed zonal sst option + + + integer :: amip_date(3)=(/-1,-1,-1/) !< amip date for repeating single day (rsd) option + + real :: sst_pert = 0. !< global temperature perturbation used for sensitivity experiments + + character(len=6) :: sst_pert_type = 'fixed' !< use 'random' or 'fixed' + logical :: do_sst_pert = .false. + logical :: use_daily = .false. !< if '.true.', give 'data_set = 'daily'' + + logical :: use_ncep_sst = .false. !< SJL: During nudging: use_ncep_sst = .T.; no_anom_sst = .T. + !! during forecast: use_ncep_sst = .T.; no_anom_sst = .F. + logical :: no_anom_sst = .true. !< SJL: During nudging: use_ncep_sst = .T.; no_anom_sst = .T. + !! during forecast: use_ncep_sst = .T.; no_anom_sst = .F. + logical :: use_ncep_ice = .false. !< For seasonal forecast: use_ncep_ice = .F. + logical :: interp_oi_sst = .false. !< changed to false for regular runs + logical :: use_mpp_io = .false. !< Set to .true. to use mpp_io, otherwise fms2io is used + + namelist /amip_interp_nml/ use_ncep_sst, no_anom_sst, use_ncep_ice, tice_crit, & + interp_oi_sst, data_set, date_out_of_range, & + use_zonal, teq, tdif, tann, tlag, amip_date, & + ! add by JHC + sst_pert, sst_pert_type, do_sst_pert, & + use_daily, & + ! end add by JHC + verbose, i_sst, j_sst, forecast_mode, & + use_mpp_io + +!----------------------------------------------------------------------- + +contains + +! modified by JHC +!> Retrieve sea surface temperature data and interpolated grid +subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model) + + type (time_type), intent(in) :: Time !< Time to interpolate + type (amip_interp_type), intent(inout) :: Interp !< Holds data for interpolation + real, intent(out) :: sst(:,:) !< Sea surface temperature data + character(len=*), optional, intent(out) :: err_msg !< Holds error message string if present + + real, dimension(mobs,nobs) :: sice + + integer :: year1, year2, month1, month2 + real :: fmonth + type (date_type) :: Date1, Date2, Udate1, Udate2 + + type(time_type) :: Amip_Time + integer :: tod(3),dum(3) + +! add by JHC + real, intent(in), dimension(:,:), optional :: lon_model, lat_model + real :: pert + integer :: i, j, mobs_sst, nobs_sst + integer :: jhctod(6) + type (time_type) :: Udate + character(len=4) :: yyyy + integer :: nrecords, ierr, k, yr, mo, dy + integer, dimension(:), allocatable :: ryr, rmo, rdy + character(len=30) :: time_unit + real, dimension(:), allocatable :: timeval + character(len=maxc) :: ncfilename + type(FmsNetcdfFile_t) :: fileobj + logical :: the_file_exists +! end add by JHC + logical, parameter :: DEBUG = .false. !> switch for debugging output + !> These are fms_io specific + integer :: unit + + if(present(err_msg)) err_msg = '' + if(.not.Interp%I_am_initialized) then + if(fms_error_handler('get_amip_sst','The amip_interp_type variable is not initialized',err_msg)) return + endif + +!----------------------------------------------------------------------- +!----- compute zonally symetric sst --------------- + + if ( use_ncep_sst .and. forecast_mode ) no_anom_sst = .false. + + if (all(amip_date>0)) then + call get_date(Time,dum(1),dum(2),dum(3),tod(1),tod(2),tod(3)) + Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3)) + else + Amip_Time = Time + endif + +! add by JHC +if ( .not.use_daily ) then +! end add by JHC + + if ( .not. allocated(temp1) ) allocate (temp1(mobs,nobs)) + if ( .not. allocated(temp2) ) allocate (temp2(mobs,nobs)) + + if (use_zonal) then + call zonal_sst (Amip_Time, sice, temp1) + call horiz_interp ( Interp%Hintrp, temp1, sst ) + else + +!----------------------------------------------------------------------- +!---------- get new observed sea surface temperature ------------------- + +! ---- time interpolation for months ----- + call time_interp (Amip_Time, fmonth, year1, year2, month1, month2) +! ---- force climatology ---- + if (Interp % use_climo) then + year1=0; year2=0 + endif + if (Interp % use_annual) then + year1=0; year2=0 + month1=0; month2=0 + endif +! --------------------------- + + Date1 = date_type( year1, month1, 0 ) + Date2 = date_type( year2, month2, 0 ) + +! -- open/rewind file -- + unit = -1 +!----------------------------------------------------------------------- + + + if (Date1 /= Interp % Date1) then +! ---- use Date2 for Date1 ---- + if (Date1 == Interp % Date2) then + Interp % Date1 = Interp % Date2 + Interp % data1 = Interp % data2 + temp1(:,:) = temp2(:,:) ! SJL BUG fix: June 24, 2011 + else + call read_record ('sst', Date1, Udate1, temp1) + if ( use_ncep_sst .and. (.not. no_anom_sst) ) then + temp1(:,:) = temp1(:,:) + sst_anom(:,:) + endif + call horiz_interp ( Interp%Hintrp, temp1, Interp%data1 ) + call clip_data ('sst', Interp%data1) + Interp % Date1 = Date1 + endif + endif + +!----------------------------------------------------------------------- + + if (Date2 /= Interp % Date2) then + call read_record ('sst', Date2, Udate2, temp2) + if ( use_ncep_sst .and. (.not. no_anom_sst) ) then + temp2(:,:) = temp2(:,:) + sst_anom(:,:) + endif + call horiz_interp ( Interp%Hintrp, temp2, Interp%data2 ) + call clip_data ('sst', Interp%data2) + Interp % Date2 = Date2 + endif + +!----------------------------------------------------------------------- +!---------- time interpolation (between months) of sst's --------------- +!----------------------------------------------------------------------- + sst = Interp % data1 + fmonth * (Interp % data2 - Interp % data1) + +!------------------------------------------------------------------------------- +! SJL mods for NWP and TCSF --- +! Nudging runs: (Note: NCEP SST updated only every 6-hr) +! Compute SST anomaly from global SST datasets for subsequent forecast runs +!------------------------------------------------------------------------------- + if ( use_ncep_sst .and. no_anom_sst ) then + sst_anom(:,:) = sst_ncep(:,:) - (temp1(:,:) + fmonth*(temp2(:,:) - temp1(:,:)) ) + call horiz_interp ( Interp%Hintrp, sst_ncep, sst ) + call clip_data ('sst', sst) + endif + +!! DEBUG CODE + if (DEBUG) then + call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) + if (mpp_pe() == 0) then + write (*,200) 'JHC: use_daily = F, AMIP_Time: ',jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5), & + & jhctod(6) + write (*,300) 'JHC: use_daily = F, interped SST: ', sst(1,1),sst(5,5),sst(10,10) + endif + endif + + + endif + +! add by JHC +else + call get_date(Amip_Time,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) + if (mpp_pe() == mpp_root_pe()) write(*,200) 'amip_interp_mod: use_daily = T, Amip_Time = ',jhctod(1), & + & jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6) + + yr = jhctod(1); mo = jhctod(2); dy = jhctod(3) + + write (yyyy,'(i4)') jhctod(1) + + file_name_sst = 'INPUT/' // 'sst.day.mean.'//yyyy//'.v2.nc' + ncfilename = trim(file_name_sst) + time_unit = 'days since 1978-01-01 00:00:00' + + mobs_sst = 1440; nobs_sst = 720 + + call set_sst_grid_edges_daily(mobs_sst, nobs_sst) + call horiz_interp_new ( Interp%Hintrp2, lon_bnd, lat_bnd, & + lon_model, lat_model, interp_method="bilinear" ) + + the_file_exists = fms2_io_file_exists(ncfilename) + + if ( (.NOT. the_file_exists) ) then + call mpp_error ('amip_interp_mod', & + 'cannot find daily SST input data file: '//trim(ncfilename), NOTE) + else + if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & + 'Reading NetCDF formatted daily SST from: '//trim(ncfilename), NOTE) + + if(.not. open_file(fileobj, trim(ncfilename), 'read')) & + call error_mesg ('get_amip_sst', 'Error in opening file '//trim(ncfilename), FATAL) + + call get_dimension_size(fileobj, 'TIME', nrecords) + if (nrecords < 1) call mpp_error('amip_interp_mod', & + 'Invalid number of SST records in daily SST data file: '//trim(ncfilename), FATAL) + allocate(timeval(nrecords), ryr(nrecords), rmo(nrecords), rdy(nrecords)) + call fms2_io_read_data(fileobj, 'TIME', timeval) +!!! DEBUG CODE + if(DEBUG) then + if (mpp_pe() == 0) then + print *, 'JHC: nrecords = ', nrecords + print *, 'JHC: TIME = ', timeval + endif + endif + + ierr = 1 + do k = 1, nrecords + + Udate = get_cal_time (timeval(k), time_unit, 'julian') + call get_date(Udate,jhctod(1),jhctod(2),jhctod(3),jhctod(4),jhctod(5),jhctod(6)) + ryr(k) = jhctod(1); rmo(k) = jhctod(2); rdy(k) = jhctod(3) + + if ( yr == ryr(k) .and. mo == rmo(k) .and. dy == rdy (k) ) ierr = 0 + if (ierr==0) exit + + enddo + + if(DEBUG) then + if (mpp_pe() == 0) then + print *, 'JHC: k =', k + print *, 'JHC: ryr(k) rmo(k) rdy(k)',ryr(k), rmo(k), rdy(k) + print *, 'JHC: yr mo dy ',yr, mo, dy + endif + endif + + if (ierr .ne. 0) call mpp_error('amip_interp_mod', & + 'Model time is out of range not in SST data: '//trim(ncfilename), FATAL) + endif ! if(file_exist(ncfilename)) + + + !---- read NETCDF data ---- + if ( .not. allocated(tempamip) ) allocate (tempamip(mobs_sst,nobs_sst)) + + if (the_file_exists) then + call fms2_io_read_data(fileobj, 'SST', tempamip, unlim_dim_level=k) + call close_file(fileobj) + tempamip = tempamip + TFREEZE + +!!! DEBUG CODE + if(DEBUG) then + if (mpp_pe() == 0) then + print*, 'JHC: TFREEZE = ', TFREEZE + print*, lbound(sst) + print*, ubound(sst) + print*, lbound(tempamip) + print*, ubound(tempamip) + write(*,300) 'JHC: tempamip : ', tempamip(100,100), tempamip(200,200), tempamip(300,300) + endif + endif + + call horiz_interp ( Interp%Hintrp2, tempamip, sst ) + call clip_data ('sst', sst) + + endif + + if(DEBUG) then + if (mpp_pe() == 400) then + write(*,300)'JHC: use_daily = T, daily SST: ', sst(1,1),sst(5,5),sst(10,10) + print *,'JHC: use_daily = T, daily SST: ', sst + endif + endif + +200 format(a35, 6(i5,1x)) +300 format(a35, 3(f7.3,2x)) + +endif +! end add by JHC + +! add by JHC: add on non-zero sea surface temperature perturbation (namelist option) +! This perturbation may be useful in accessing model sensitivities + + if ( do_sst_pert ) then + + if ( trim(sst_pert_type) == 'fixed' ) then + sst = sst + sst_pert + else if ( trim(sst_pert_type) == 'random' ) then + call random_seed() + + if(DEBUG) then + if (mpp_pe() == 0) then + print*, 'mobs = ', mobs + print*, 'nobs = ', nobs + print*, lbound(sst) + print*, ubound(sst) + endif + endif + + do i = 1, size(sst,1) + do j = 1, size(sst,2) + call random_number(pert) + sst (i,j) = sst (i,j) + sst_pert*((pert-0.5)*2) + end do + end do + endif + + endif +! end add by JHC + +!----------------------------------------------------------------------- + + end subroutine get_amip_sst + +!> AMIP interpolation for ice +subroutine get_amip_ice (Time, Interp, ice, err_msg) + + type (time_type), intent(in) :: Time !< Time to interpolate + type (amip_interp_type), intent(inout) :: Interp !< Holds data for interpolation + real, intent(out) :: ice(:,:) !< ice data + character(len=*), optional, intent(out) :: err_msg !< Holds error message string if present + + real, dimension(mobs,nobs) :: sice, temp + + integer :: year1, year2, month1, month2 + real :: fmonth + type (date_type) :: Date1, Date2, Udate1, Udate2 + + type(time_type) :: Amip_Time + integer :: tod(3),dum(3) + + if(present(err_msg)) err_msg = '' + if(.not.Interp%I_am_initialized) then + if(fms_error_handler('get_amip_ice','The amip_interp_type variable is not initialized',err_msg)) return + endif + +!----------------------------------------------------------------------- +!----- compute zonally symetric sst --------------- + + + if (any(amip_date>0)) then + + call get_date(Time,dum(1),dum(2),dum(3),tod(1),tod(2),tod(3)) + + Amip_Time = set_date(amip_date(1),amip_date(2),amip_date(3),tod(1),tod(2),tod(3)) + + else + + Amip_Time = Time + + endif + + +if (use_zonal) then + call zonal_sst (Amip_Time, sice, temp) + call horiz_interp ( Interp%Hintrp, sice, ice ) +else + +!----------------------------------------------------------------------- +!---------- get new observed sea surface temperature ------------------- + +! ---- time interpolation for months ----- + + call time_interp (Amip_Time, fmonth, year1, year2, month1, month2) + +! ---- force climatology ---- + if (Interp % use_climo) then + year1=0; year2=0 + endif + if (Interp % use_annual) then + year1=0; year2=0 + month1=0; month2=0 + endif +! --------------------------- + + Date1 = date_type( year1, month1, 0 ) + Date2 = date_type( year2, month2, 0 ) + + unit = -1 +!----------------------------------------------------------------------- + + if (Date1 /= Interp % Date1) then +! ---- use Date2 for Date1 ---- + if (Date1 == Interp % Date2) then + Interp % Date1 = Interp % Date2 + Interp % data1 = Interp % data2 + else +!-- SJL ------------------------------------------------------------- +! Can NOT use ncep_sst to determine sea_ice For seasonal forecast +! Use climo sea ice for seasonal runs + if ( use_ncep_sst .and. use_ncep_ice ) then + where ( sst_ncep <= (TFREEZE+tice_crit) ) + sice = 1. + elsewhere + sice = 0. + endwhere + else + call read_record ('ice', Date1, Udate1, sice) + endif +!-------------------------------------------------------------------- + call horiz_interp ( Interp%Hintrp, sice, Interp%data1 ) + call clip_data ('ice', Interp%data1) + Interp % Date1 = Date1 + endif + endif + +!----------------------------------------------------------------------- + + if (Date2 /= Interp % Date2) then + +!-- SJL ------------------------------------------------------------- + if ( use_ncep_sst .and. use_ncep_ice ) then + where ( sst_ncep <= (TFREEZE+tice_crit) ) + sice = 1. + elsewhere + sice = 0. + endwhere + else + call read_record ('ice', Date2, Udate2, sice) + endif +!-------------------------------------------------------------------- + call horiz_interp ( Interp%Hintrp, sice, Interp%data2 ) + call clip_data ('ice', Interp%data2) + Interp % Date2 = Date2 + + endif + +!----------------------------------------------------------------------- +!---------- time interpolation (between months) ------------------------ +!----------------------------------------------------------------------- + + ice = Interp % data1 + fmonth * (Interp % data2 - Interp % data1) + +endif + +!----------------------------------------------------------------------- + + end subroutine get_amip_ice + +!####################################################################### + + !> @return A newly created @ref amip_interp_type + function amip_interp_new_1d ( lon , lat , mask , use_climo, use_annual, & + interp_method ) result (Interp) + + real, intent(in), dimension(:) :: lon, lat + logical, intent(in), dimension(:,:) :: mask + character(len=*), intent(in), optional :: interp_method + logical, intent(in), optional :: use_climo, use_annual + + type (amip_interp_type) :: Interp + + if(.not.module_is_initialized) call amip_interp_init + + Interp % use_climo = .false. + if (present(use_climo)) Interp % use_climo = use_climo + Interp % use_annual = .false. + if (present(use_annual)) Interp % use_annual = use_annual + + if ( date_out_of_range == 'fail' .and. Interp%use_climo ) & + call error_mesg ('amip_interp_new_1d', 'use_climo mismatch', FATAL) + + if ( date_out_of_range == 'fail' .and. Interp%use_annual ) & + call error_mesg ('amip_interp_new_1d', 'use_annual(climo) mismatch', FATAL) + + Interp % Date1 = date_type( -99, -99, -99 ) + Interp % Date2 = date_type( -99, -99, -99 ) + +!----------------------------------------------------------------------- +! ---- initialization of horizontal interpolation ---- + + call horiz_interp_new ( Interp%Hintrp, lon_bnd, lat_bnd, & + lon, lat, interp_method= interp_method ) + + allocate ( Interp % data1 (size(lon(:))-1,size(lat(:))-1), & + Interp % data2 (size(lon(:))-1,size(lat(:))-1) ) + + Interp%I_am_initialized = .true. + + end function amip_interp_new_1d + + !> @return A newly created @ref amip_interp_type + function amip_interp_new_2d ( lon , lat , mask , use_climo, use_annual, & + interp_method ) result (Interp) + + real, intent(in), dimension(:,:) :: lon, lat + logical, intent(in), dimension(:,:) :: mask + character(len=*), intent(in), optional :: interp_method + logical, intent(in), optional :: use_climo, use_annual + + type (amip_interp_type) :: Interp + + if(.not.module_is_initialized) call amip_interp_init + + Interp % use_climo = .false. + if (present(use_climo)) Interp % use_climo = use_climo + Interp % use_annual = .false. + if (present(use_annual)) Interp % use_annual = use_annual + + if ( date_out_of_range == 'fail' .and. Interp%use_climo ) & + call error_mesg ('amip_interp_new_2d', 'use_climo mismatch', FATAL) + + if ( date_out_of_range == 'fail' .and. Interp%use_annual ) & + call error_mesg ('amip_interp_new_2d', 'use_annual(climo) mismatch', FATAL) + + Interp % Date1 = date_type( -99, -99, -99 ) + Interp % Date2 = date_type( -99, -99, -99 ) + +!----------------------------------------------------------------------- +! ---- initialization of horizontal interpolation ---- + + call horiz_interp_new ( Interp%Hintrp, lon_bnd, lat_bnd, & + lon, lat, interp_method = interp_method) + + allocate ( Interp % data1 (size(lon,1),size(lat,2)), & + Interp % data2 (size(lon,1),size(lat,2))) + + Interp%I_am_initialized = .true. + + end function amip_interp_new_2d + +!####################################################################### + + !> initialize @ref amip_interp_mod for use + subroutine amip_interp_init() + + integer :: unit,io,ierr + +!----------------------------------------------------------------------- + + call horiz_interp_init + +! ---- read namelist ---- + + read (input_nml_file, amip_interp_nml, iostat=io) + ierr = check_nml_error(io,'amip_interp_nml') + +! ----- write namelist/version info ----- + call write_version_number("AMIP_INTERP_MOD", version) + + unit = stdlog ( ) + if (mpp_pe() == 0) then + write (unit,nml=amip_interp_nml) + endif + + if (use_mpp_io) then + !! USE_MPP_IO_WARNING + call mpp_error ('amip_interp_mod', & + 'MPP_IO is no longer supported. Please remove use_mpp_io from amip_interp_nml',& + FATAL) + endif + if ( .not. use_ncep_sst ) interp_oi_sst = .false. + +! ---- freezing point of sea water in deg K --- + + tice_crit_k = tice_crit + if ( tice_crit_k < 200. ) tice_crit_k = tice_crit_k + TFREEZE + ice_crit = nint((tice_crit_k-TFREEZE)*100., I2_KIND) + +! ---- set up file dependent variable ---- +! ---- global file name ---- +! ---- grid box edges ---- +! ---- initialize zero size grid if not pe 0 ------ + + if (lowercase(trim(data_set)) == 'amip1') then + file_name_sst = 'INPUT/' // 'amip1_sst.data' + file_name_ice = 'INPUT/' // 'amip1_sst.data' + mobs = 180; nobs = 91 + call set_sst_grid_edges_amip1 + if (mpp_pe() == 0) & + call error_mesg ('amip_interp_init', 'using AMIP 1 sst', NOTE) + Date_end = date_type( 1989, 1, 0 ) + else if (lowercase(trim(data_set)) == 'amip2') then + file_name_sst = 'INPUT/' // 'amip2_sst.data' + file_name_ice = 'INPUT/' // 'amip2_ice.data' + mobs = 360; nobs = 180 + call set_sst_grid_edges_oi +! --- specfied min for amip2 --- + tice_crit_k = 271.38 + if (mpp_pe() == 0) & + call error_mesg ('amip_interp_init', 'using AMIP 2 sst', NOTE) + Date_end = date_type( 1996, 3, 0 ) + else if (lowercase(trim(data_set)) == 'hurrell') then + file_name_sst = 'INPUT/' // 'hurrell_sst.data' + file_name_ice = 'INPUT/' // 'hurrell_ice.data' + mobs = 360; nobs = 180 + call set_sst_grid_edges_oi +! --- specfied min for hurrell --- + tice_crit_k = 271.38 + if (mpp_pe() == 0) & + call error_mesg ('amip_interp_init', 'using HURRELL sst', NOTE) + Date_end = date_type( 2011, 8, 16 ) ! updated by JHC +! add by JHC + else if (lowercase(trim(data_set)) == 'daily') then + file_name_sst = 'INPUT/' // 'hurrell_sst.data' + file_name_ice = 'INPUT/' // 'hurrell_ice.data' + mobs = 360; nobs = 180 + call set_sst_grid_edges_oi + if (mpp_pe() == 0) & + call error_mesg ('amip_interp_init', 'using AVHRR daily sst', NOTE) + Date_end = date_type( 2011, 8, 16 ) +! end add by JHC + else if (lowercase(trim(data_set)) == 'reynolds_eof') then + file_name_sst = 'INPUT/' // 'reynolds_sst.data' + file_name_ice = 'INPUT/' // 'reynolds_sst.data' + mobs = 180; nobs = 90 + call set_sst_grid_edges_oi + if (mpp_pe() == 0) & + call error_mesg ('amip_interp_init', & + 'using NCEP Reynolds Historical Reconstructed SST', NOTE) + Date_end = date_type( 1998, 12, 0 ) + else if (lowercase(trim(data_set)) == 'reynolds_oi') then + file_name_sst = 'INPUT/' // 'reyoi_sst.data' + file_name_ice = 'INPUT/' // 'reyoi_sst.data' +!--- Added by SJL ---------------------------------------------- + if ( use_ncep_sst ) then + mobs = i_sst; nobs = j_sst + if (.not. allocated (sst_ncep)) then + allocate (sst_ncep(i_sst,j_sst)) + sst_ncep(:,:) = big_number + endif + if (.not. allocated (sst_anom)) then + allocate (sst_anom(i_sst,j_sst)) + sst_anom(:,:) = big_number + endif + else + mobs = 360; nobs = 180 + endif +!--- Added by SJL ---------------------------------------------- + call set_sst_grid_edges_oi + if (mpp_pe() == 0) & + call error_mesg ('amip_interp_init', 'using Reynolds OI SST', & + NOTE) + Date_end = date_type( 1999, 1, 0 ) + else + call error_mesg ('amip_interp_init', 'the value of the & + &namelist parameter DATA_SET being used is not allowed', FATAL) + endif + + if (verbose > 1 .and. mpp_pe() == 0) & + print *, 'ice_crit,tice_crit_k=',ice_crit,tice_crit_k + +! --- check existence of sst data file ??? --- + file_name_sst = trim(file_name_sst)//'.nc' + file_name_ice = trim(file_name_ice)//'.nc' + + if (.not. fms2_io_file_exists(trim(file_name_sst)) ) then + call error_mesg ('amip_interp_init', & + 'file '//trim(file_name_sst)//' does not exist', FATAL) + endif + if (.not. fms2_io_file_exists(trim(file_name_ice)) ) then + call error_mesg ('amip_interp_init', & + 'file '//trim(file_name_ice)//' does not exist', FATAL) + endif + + if (.not. open_file(fileobj_sst, trim(file_name_sst), 'read')) & + call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_sst), FATAL) + if (.not. open_file(fileobj_ice, trim(file_name_ice), 'read')) & + call error_mesg ('amip_interp_init', 'Error in opening file '//trim(file_name_ice), FATAL) + module_is_initialized = .true. + + end subroutine amip_interp_init + +!####################################################################### + +!> Frees data associated with a amip_interp_type variable. Should be used for any +!! variables initialized via @ref amip_interp_new. +!> @param[inout] Interp A defined data type variable initialized by amip_interp_new and used +!! when calling get_amip_sst and get_amip_ice. + subroutine amip_interp_del (Interp) + type (amip_interp_type), intent(inout) :: Interp + if(associated(Interp%data1)) deallocate(Interp%data1) + if(associated(Interp%data2)) deallocate(Interp%data2) + if(allocated(lon_bnd)) deallocate(lon_bnd) + if(allocated(lat_bnd)) deallocate(lat_bnd) + call horiz_interp_del ( Interp%Hintrp ) + + Interp%I_am_initialized = .false. + + end subroutine amip_interp_del + +!####################################################################### + + subroutine set_sst_grid_edges_amip1 + + integer :: i, j + real :: hpie, dlon, dlat, wb, sb + + allocate ( lon_bnd(mobs+1), lat_bnd(nobs+1) ) + +! ---- compute grid edges (do only once) ----- + + hpie = 0.5*pi + + dlon = 4.*hpie/float(mobs); wb = -0.5*dlon + do i = 1, mobs+1 + lon_bnd(i) = wb + dlon * float(i-1) + enddo + lon_bnd(mobs+1) = lon_bnd(1) + 4.*hpie + + dlat = 2.*hpie/float(nobs-1); sb = -hpie + 0.5*dlat + lat_bnd(1) = -hpie; lat_bnd(nobs+1) = hpie + do j = 2, nobs + lat_bnd(j) = sb + dlat * float(j-2) + enddo + + end subroutine set_sst_grid_edges_amip1 + +!####################################################################### + subroutine set_sst_grid_edges_oi + + integer :: i, j + real :: hpie, dlon, dlat, wb, sb + +! add by JHC + if(allocated(lon_bnd)) deallocate(lon_bnd) + if(allocated(lat_bnd)) deallocate(lat_bnd) +! end add by JHC + allocate ( lon_bnd(mobs+1), lat_bnd(nobs+1) ) + +! ---- compute grid edges (do only once) ----- + + hpie = 0.5*pi + + dlon = 4.*hpie/float(mobs); wb = 0.0 + lon_bnd(1) = wb + do i = 2, mobs+1 + lon_bnd(i) = wb + dlon * float(i-1) + enddo + lon_bnd(mobs+1) = lon_bnd(1) + 4.*hpie + + dlat = 2.*hpie/float(nobs); sb = -hpie + lat_bnd(1) = sb; lat_bnd(nobs+1) = hpie + do j = 2, nobs + lat_bnd(j) = sb + dlat * float(j-1) + enddo + + end subroutine set_sst_grid_edges_oi +!####################################################################### +! add by JHC + subroutine set_sst_grid_edges_daily(mobs_sst, nobs_sst) + + integer :: i, j, mobs_sst, nobs_sst + real :: hpie, dlon, dlat, wb, sb + + if(allocated(lon_bnd)) deallocate(lon_bnd) + if(allocated(lat_bnd)) deallocate(lat_bnd) + allocate ( lon_bnd(mobs_sst+1), lat_bnd(nobs_sst+1) ) + +! ---- compute grid edges (do only once) ----- + + hpie = 0.5*pi + + dlon = 4.*hpie/float(mobs_sst); wb = 0.0 + lon_bnd(1) = wb + do i = 2, mobs_sst+1 + lon_bnd(i) = wb + dlon * float(i-1) + enddo + lon_bnd(mobs_sst+1) = lon_bnd(1) + 4.*hpie + + dlat = 2.*hpie/float(nobs_sst); sb = -hpie + lat_bnd(1) = sb; lat_bnd(nobs_sst+1) = hpie + do j = 2, nobs_sst + lat_bnd(j) = sb + dlat * float(j-1) + enddo + + end subroutine set_sst_grid_edges_daily +! end add by JHC +!####################################################################### + + + subroutine a2a_bilinear(nx, ny, dat1, n1, n2, dat2) + integer, intent(in):: nx, ny + integer, intent(in):: n1, n2 + real, intent(in) :: dat1(nx,ny) + real, intent(out):: dat2(n1,n2) !> output interpolated data + +! local: + real:: lon1(nx), lat1(ny) + real:: lon2(n1), lat2(n2) + real:: dx1, dy1, dx2, dy2 + real:: xc, yc + real:: a1, b1, c1, c2, c3, c4 + integer i1, i2, jc, i0, j0, it, jt + integer i,j + + +!----------------------------------------------------------- +! * Interpolate from "FMS" 1x1 SST data grid to a finer grid +! lon: 0.5, 1.5, ..., 359.5 +! lat: -89.5, -88.5, ... , 88.5, 89.5 +!----------------------------------------------------------- + + dx1 = 360./real(nx) !> INput Grid + dy1 = 180./real(ny) !> INput Grid + + do i=1,nx + lon1(i) = 0.5*dx1 + real(i-1)*dx1 + enddo + do j=1,ny + lat1(j) = -90. + 0.5*dy1 + real(j-1)*dy1 + enddo + + dx2 = 360./real(n1) !> OutPut Grid: + dy2 = 180./real(n2) !> OutPut Grid: + + do i=1,n1 + lon2(i) = 0.5*dx2 + real(i-1)*dx2 + enddo + do j=1,n2 + lat2(j) = -90. + 0.5*dy2 + real(j-1)*dy2 + enddo + + jt = 1 + do 5000 j=1,n2 + + yc = lat2(j) + if ( yclat1(ny) ) then + jc = ny-1 + b1 = 1. + else + do j0=jt,ny-1 + if ( yc>=lat1(j0) .and. yc<=lat1(j0+1) ) then + jc = j0 + jt = j0 + b1 = (yc-lat1(jc)) / dy1 + go to 222 + endif + enddo + endif +222 continue + + it = 1 + do i=1,n1 + xc = lon2(i) + if ( xc>lon1(nx) ) then + i1 = nx; i2 = 1 + a1 = (xc-lon1(nx)) / dx1 + elseif ( xc=lon1(i0) .and. xc<=lon1(i0+1) ) then + i1 = i0; i2 = i0+1 + it = i0 + a1 = (xc-lon1(i1)) / dx1 + go to 111 + endif + enddo + endif +111 continue + +! Debug code: + if ( a1<-0.001 .or. a1>1.001 .or. b1<-0.001 .or. b1>1.001 ) then + write(*,*) i,j,a1, b1 + call mpp_error(FATAL,'a2a bilinear interpolation') + endif + + c1 = (1.-a1) * (1.-b1) + c2 = a1 * (1.-b1) + c3 = a1 * b1 + c4 = (1.-a1) * b1 + +! Bilinear interpolation: + dat2(i,j) = c1*dat1(i1,jc) + c2*dat1(i2,jc) + c3*dat1(i2,jc+1) + c4*dat1(i1,jc+1) + + enddo !i-loop + +5000 continue ! j-loop + + end subroutine a2a_bilinear + +!####################################################################### + +!> @brief Returns the size (i.e., number of longitude and latitude +!! points) of the observed data grid. +!! @throws FATAL have not called amip_interp_new +!! Must call amip_interp_new before get_sst_grid_size. + subroutine get_sst_grid_size (nlon, nlat) + + integer, intent(out) :: nlon !> The number of longitude points (first dimension) in the + !! observed data grid. For AMIP 1 nlon = 180, and the Reynolds nlon = 360. + integer, intent(out) :: nlat !> The number of latitude points (second dimension) in the + !! observed data grid. For AMIP 1 nlon = 91, and the Reynolds nlon = 180. + + if ( .not.module_is_initialized ) call amip_interp_init + + nlon = mobs; nlat = nobs + + end subroutine get_sst_grid_size + +!####################################################################### + +!> @brief Returns the grid box boundaries of the observed data grid. +!! +!! @throws FATAL, have not called amip_interp_new +!! Must call amip_interp_new before get_sst_grid_boundary. +!! +!! @throws FATAL, invalid argument dimensions +!! The size of the output argument arrays do not agree with +!! the size of the observed data. See the documentation for +!! interfaces get_sst_grid_size and get_sst_grid_boundary. + subroutine get_sst_grid_boundary (blon, blat, mask) + + real, intent(out) :: blon(:) !> The grid box edges (in radians) for longitude points of the + !! observed data grid. The size of this argument must be nlon+1. + real, intent(out) :: blat(:) !> The grid box edges (in radians) for latitude points of the + !! observed data grid. The size of this argument must be nlat+1. + logical, intent(out) :: mask(:,:) + + if ( .not.module_is_initialized ) call amip_interp_init + +! ---- check size of argument(s) ---- + + if (size(blon(:)) /= mobs+1 .or. size(blat(:)) /= nobs+1) & + call error_mesg ('get_sst_grid_boundary in amip_interp_mod', & + 'invalid argument dimensions', FATAL) + +! ---- return grid box edges ----- + + blon = lon_bnd + blat = lat_bnd + +! ---- masking (data exists at all points) ---- + + mask = .true. + + + end subroutine get_sst_grid_boundary + +!####################################################################### + + subroutine read_record (type, Date, Adate, dat) + + character(len=*), intent(in) :: type + type (date_type), intent(in) :: Date + type (date_type), intent(inout) :: Adate + real, intent(out) :: dat(mobs,nobs) + real :: tmp_dat(360,180) + + integer(I2_KIND) :: idat(mobs,nobs) + integer :: nrecords, yr, mo, dy, ierr, k + integer, dimension(:), allocatable :: ryr, rmo, rdy + character(len=maxc) :: ncfilename, ncfieldname + type(FmsNetcdfFile_t), pointer :: fileobj + + !---- set file and field name for NETCDF data sets ---- + + ncfieldname = 'sst' + if(type(1:3) == 'sst') then + ncfilename = trim(file_name_sst) + fileobj => fileobj_sst + else if(type(1:3) == 'ice') then + ncfilename = trim(file_name_ice) + fileobj => fileobj_ice + if (lowercase(trim(data_set)) == 'amip2' .or. & + lowercase(trim(data_set)) == 'hurrell' .or. & + lowercase(trim(data_set)) == 'daily') ncfieldname = 'ice' ! modified by JHC + endif + + dy = 0 ! only processing monthly data + + if (verbose > 2 .and. mpp_pe() == 0) & + print *, 'looking for date = ', Date + + ! This code can handle amip1, reynolds, or reyoi type SST data files in netCDF format + if (mpp_pe() == mpp_root_pe()) call mpp_error ('amip_interp_mod', & + 'Reading NetCDF formatted input data file: '//trim(ncfilename), NOTE) + + call fms2_io_read_data (fileobj, 'nrecords', nrecords) + if (nrecords < 1) call mpp_error('amip_interp_mod', & + 'Invalid number of SST records in SST datafile: '//trim(ncfilename), FATAL) + allocate(ryr(nrecords), rmo(nrecords), rdy(nrecords)) + call fms2_io_read_data(fileobj, 'yr', ryr) + call fms2_io_read_data(fileobj, 'mo', rmo) + call fms2_io_read_data(fileobj, 'dy', rdy) + + ierr = 1 + do k = 1, nrecords + yr = ryr(k); mo = rmo(k) + Adate = date_type( yr, mo, 0) + Curr_date = Adate + if (verbose > 2 .and. mpp_pe() == 0) & + print *, '....... checking ', Adate + if (Date == Adate) ierr = 0 + if (yr == 0 .and. mo == Date%month) ierr = 0 + if (ierr == 0) exit + enddo + if (ierr .ne. 0) call mpp_error('amip_interp_mod', & + 'Model time is out of range not in SST data: '//trim(ncfilename), FATAL) + deallocate(ryr, rmo, rdy) + !PRINT *, 'New SST data: ', k, yr, mo, dy, Date%year, Date%month, Date%day, ryr(1), rmo(1) + + !---- check if climatological data should be used ---- + + if (yr == 0 .or. mo == 0) then + ierr = 0 + if (date_out_of_range == 'fail' ) ierr = 1 + if (date_out_of_range == 'initclimo' .and. & + Date > Date_end ) ierr = 1 + if (ierr /= 0) call error_mesg & + ('read_record in amip_interp_mod', & + 'climo data read when NO climo data requested', FATAL) + endif + + !---- read NETCDF data ---- + + if ( interp_oi_sst ) then + call fms2_io_read_data(fileobj, ncfieldname, tmp_dat, unlim_dim_level=k) +! interpolate tmp_dat(360, 180) ---> dat(mobs,nobs) (to enable SST anom computation) + if ( mobs/=360 .or. nobs/=180 ) then + call a2a_bilinear(360, 180, tmp_dat, mobs, nobs, dat) + else + dat(:,:) = tmp_dat(:,:) + endif + else + call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k) + endif + idat = nint(dat, I2_KIND) ! reconstruct packed data for reproducibility + + !---- unpacking of data ---- + + if (type(1:3) == 'ice') then + !---- create fractional [0,1] ice mask + if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then + where ( idat <= ice_crit ) + dat = 1. + elsewhere + dat = 0. + endwhere + else + dat = dat*0.01 + endif + else if (type(1:3) == 'sst') then + !---- unpack sst ---- + if (lowercase(trim(data_set)) /= 'amip2' .and. lowercase(trim(data_set)) /= 'hurrell') then + dat = real(idat)*0.01 + TFREEZE + endif + endif + + return + + end subroutine read_record + +!####################################################################### + + subroutine clip_data (type, dat) + + character(len=*), intent(in) :: type + real, intent(inout) :: dat(:,:) + + if (type(1:3) == 'ice') then + dat = min(max(dat,0.0),1.0) + else if (type(1:3) == 'sst') then + dat = max(tice_crit_k,dat) + endif + + end subroutine clip_data + +!####################################################################### + +!> @return logical answer +function date_equals (Left, Right) result (answer) +type (date_type), intent(in) :: Left, Right +logical :: answer + + if (Left % year == Right % year .and. & + Left % month == Right % month .and. & + Left % day == Right % day ) then + answer = .true. + else + answer = .false. + endif + +end function date_equals + +!####################################################################### + +!> @return logical answer +function date_not_equals (Left, Right) result (answer) +type (date_type), intent(in) :: Left, Right +logical :: answer + + if (Left % year == Right % year .and. & + Left % month == Right % month .and. & + Left % day == Right % day ) then + answer = .false. + else + answer = .true. + endif + +end function date_not_equals + +!####################################################################### + +!> @return logical answer +function date_gt (Left, Right) result (answer) +type (date_type), intent(in) :: Left, Right +logical :: answer +integer :: i, dif(3) + + dif(1) = Left%year - Right%year + dif(2) = Left%month - Right%month + dif(3) = Left%day - Right%day + answer = .false. + do i = 1, 3 + if (dif(i) == 0) cycle + if (dif(i) < 0) exit + if (dif(i) > 0) then + answer = .true. + exit + endif + enddo + +end function date_gt + +!####################################################################### + +subroutine print_dates (Time, Date1, Udate1, & + Date2, Udate2, fmonth) + + type (time_type), intent(in) :: Time + type (date_type), intent(in) :: Date1, Udate1, Date2, Udate2 + real, intent(in) :: fmonth + + integer :: year, month, day, hour, minute, second + + call get_date (Time, year, month, day, hour, minute, second) + + write (*,10) year,month,day, hour,minute,second + write (*,20) fmonth + write (*,30) Date1, Udate1 + write (*,40) Date2, Udate2 + +10 format (/,' date(y/m/d h:m:s) = ',i4,2('/',i2.2),1x,2(i2.2,':'),i2.2) +20 format (' fmonth = ',f9.7) +30 format (' date1(y/m/d) = ',i4,2('/',i2.2),6x, & + 'used = ',i4,2('/',i2.2),6x ) +40 format (' date2(y/m/d) = ',i4,2('/',i2.2),6x, & + 'used = ',i4,2('/',i2.2),6x ) + +end subroutine print_dates + +!####################################################################### + +subroutine zonal_sst (Time, ice, sst) + + type (time_type), intent(in) :: Time + real, intent(out) :: ice(mobs,nobs), sst(mobs,nobs) + + real :: tpi, fdate, eps, ph, sph, sph2, ts + integer :: j + +! namelist needed +! +! teq = sst at equator +! tdif = equator to pole sst difference +! tann = amplitude of annual cycle +! tlag = offset for time of year (for annual cycle) +! + + tpi = 2.0*pi + + fdate = fraction_of_year (Time) + + eps = sin( tpi*(fdate-tlag) ) * tann + + do j = 1, nobs + + ph = 0.5*(lat_bnd(j)+lat_bnd(j+1)) + sph = sin(ph) + sph2 = sph*sph + + ts = teq - tdif*sph2 - eps*sph + + sst(:,j) = ts + + enddo + + where ( sst < tice_crit_k ) + ice = 1.0 + sst = tice_crit_k + elsewhere + ice = 0.0 + endwhere + + +end subroutine zonal_sst + +!####################################################################### + +subroutine amip_interp_type_eq(amip_interp_out, amip_interp_in) + type(amip_interp_type), intent(inout) :: amip_interp_out + type(amip_interp_type), intent(in) :: amip_interp_in + + if(.not.amip_interp_in%I_am_initialized) then + call mpp_error(FATAL,'amip_interp_type_eq: amip_interp_type variable on right hand side is unassigned') + endif + + amip_interp_out%Hintrp = amip_interp_in%Hintrp + amip_interp_out%data1 => amip_interp_in%data1 + amip_interp_out%data2 => amip_interp_in%data2 + amip_interp_out%Date1 = amip_interp_in%Date1 + amip_interp_out%Date2 = amip_interp_in%Date2 + amip_interp_out%Date1 = amip_interp_in%Date1 + amip_interp_out%Date2 = amip_interp_in%Date2 + amip_interp_out%use_climo = amip_interp_in%use_climo + amip_interp_out%use_annual = amip_interp_in%use_annual + amip_interp_out%I_am_initialized = .true. + +end subroutine amip_interp_type_eq + +!####################################################################### + +end module amip_interp_mod +!> @} +! + +! +! Add AMIP 2 data set. +! +! Other data sets (or extend current data sets). +! + +! diff --git a/astronomy/include/astronomy.inc b/astronomy/include/astronomy.inc new file mode 100644 index 0000000000..192fc8f22a --- /dev/null +++ b/astronomy/include/astronomy.inc @@ -0,0 +1,2250 @@ +!*********************************************************************** +!* 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 astronomy_mod astronomy_mod +!> @ingroup astronomy +!> @brief Provides astronomical variables for use +!! by other modules within fms. The only currently used interface is +!! for determination of astronomical values needed by the shortwave +!! radiation packages. +!> @author Fei Liu + +!> @addtogroup astronomy_mod +!> @{ +module astronomy_mod + + +use fms_mod, only: fms_init, & + mpp_pe, mpp_root_pe, stdlog, & + write_version_number, & + check_nml_error, error_mesg, & + FATAL, NOTE, WARNING +use time_manager_mod, only: time_type, set_time, get_time, & + get_date_julian, set_date_julian, & + set_date, length_of_year, & + time_manager_init, & + operator(-), operator(+), & + operator( // ), operator(<) +use constants_mod, only: constants_init, PI +use mpp_mod, only: input_nml_file + +!-------------------------------------------------------------------- + +implicit none +private + +!--------------------------------------------------------------------- +!----------- version number for this module -------------------------- + +! Include variable "version" to be written to log file. +#include + + +!--------------------------------------------------------------------- +!------- interfaces -------- + +public & + astronomy_init, get_period, set_period, & + set_orbital_parameters, get_orbital_parameters, & + set_ref_date_of_ae, get_ref_date_of_ae, & + diurnal_solar, daily_mean_solar, annual_mean_solar, & + astronomy_end, universal_time, orbital_time + +!> @} + +!> @brief Calculates solar information for the given location(lat & lon) and time +!! +!> ~~~~~~~~~~{.f90} +!! call diurnal_solar (lat, lon, time, cosz, fracday, rrsun, dt_time) +!! call diurnal_solar (lat, lon, gmt, time_since_ae, cosz, fracday, rrsun, dt) +!! ~~~~~~~~~~ +!! +!! The first option (used in conjunction with time_manager_mod) +!! generates the real variables gmt and time_since_ae from the +!! time_type input, and then calls diurnal_solar with these real inputs. +!! +!! The time of day is set by +!! ~~~~~~~~~~{.f90} +!! real, intent(in) :: gmt +!! ~~~~~~~~~~ +!! The time of year is set by +!! ~~~~~~~~~~{.f90} +!! real, intent(in) :: time_since_ae +!! ~~~~~~~~~~ +!! with time_type input, both of these are extracted from +!! ~~~~~~~~~~{.f90} +!! type(time_type), intent(in) :: time +!! ~~~~~~~~~~ +!! +!! Separate routines exist within this interface for scalar, +!! 1D or 2D input and output fields: +!! +!! ~~~~~~~~~~{.f90} +!! real, intent(in), dimension(:,:) :: lat, lon +!! real, intent(in), dimension(:) :: lat, lon +!! real, intent(in) :: lat, lon +!! +!! real, intent(out), dimension(:,:) :: cosz, fracday +!! real, intent(out), dimension(:) :: cosz, fracday +!! real, intent(out) :: cosz, fracday +!! ~~~~~~~~~~ +!! +!! One may also average the output fields over the time interval +!! between gmt and gmt + dt by including the optional argument dt (or +!! dt_time). dt is measured in radians and must be less than pi +!! (1/2 day). This average is computed analytically, and should be +!! exact except for the fact that changes in earth-sun distance over +!! the time interval dt are ignored. In the context of a diurnal GCM, +!! this option should always be employed to insure that the total flux +!! at the top of the atmosphere is not modified by time truncation error. +!! +!! ~~~~~~~~~~{.f90} +!! real, intent(in), optional :: dt +!! type(time_type), optional :: dt_time +!! ~~~~~~~~~~ +!! +!! @param [in] Latitudes of model grid points [radians] +!! @param [in] Longitudes of model grid points [radians] +!! @param [in] Time of day at longitude 0.0; midnight = 0.0, one day = 2 * pi [radians] +!! @param [in] Time of year; autumnal equinox = 0.0, one year = 2 * pi [radians] +!! @param [in]