From e23cd38379c5df3686bd9e33b0466d94a158ca35 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Mon, 14 Feb 2022 14:43:14 -0500 Subject: [PATCH] Revert "feat: emc changes for mixedmode (#857) (#898)" This reverts commit 516a5efa681e5ae954c11c0c90677b4444e28ec4. --- CMakeLists.txt | 2 - constants4/constants4.F90 | 176 -- constants4/fmsconstants4.F90 | 32 - diag_manager/diag_axis.F90 | 24 +- diag_manager/diag_grid.F90 | 73 +- diag_manager/diag_manager.F90 | 688 +++-- diag_manager/diag_util.F90 | 38 +- sat_vapor_pres/sat_vapor_pres.F90 | 272 +- sat_vapor_pres/sat_vapor_pres_k.F90 | 3648 +++++---------------------- time_manager/time_manager.F90 | 28 +- tracer_manager/tracer_manager.F90 | 58 +- 11 files changed, 1095 insertions(+), 3944 deletions(-) delete mode 100644 constants4/constants4.F90 delete mode 100644 constants4/fmsconstants4.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 31710aa7a7..524307c7dc 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -100,8 +100,6 @@ list(APPEND fms_fortran_src_files column_diagnostics/column_diagnostics.F90 constants/constants.F90 constants/fmsconstants.F90 - constants4/constants4.F90 - constants4/fmsconstants4.F90 coupler/atmos_ocean_fluxes.F90 coupler/coupler_types.F90 coupler/ensemble_manager.F90 diff --git a/constants4/constants4.F90 b/constants4/constants4.F90 deleted file mode 100644 index c244b6a428..0000000000 --- a/constants4/constants4.F90 +++ /dev/null @@ -1,176 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS is free software: you can redistribute it and/or modify it under -!* the terms of the GNU Lesser General Public License as published by -!* the Free Software Foundation, either version 3 of the License, or (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -!* for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with FMS. If not, see . -!*********************************************************************** -!> @defgroup constants_mod constants_mod -!> @ingroup constants -!> @brief Defines useful constants for Earth. Constants are defined as real -!! parameters. Constants are accessed through the "use" statement. -!> @author Bin Li -!! -!> Constants have been declared as type REAL, PARAMETER. -!! -!! The value a constant can not be changed in a users program. -!! New constants can be defined in terms of values from the -!! constants module using a parameter statement.

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

-!! -!! Constants can be used on the right side on an assignment statement -!! (their value can not be reassigned). -!! -!! Example: -!! -!! @verbatim -!! use constants_mod, only: TFREEZE, grav_new => GRAV -!! real, parameter :: grav_inv = 1.0 / grav_new -!! tempc(:,:,:) = tempk(:,:,:) - TFREEZE -!! geopotential(:,:) = height(:,:) * grav_new -!! @endverbatim - -!> @file -!> @brief File for @ref constants_mod - -!> @addtogroup constants_mod -!> @{ -module constantsR4_mod - -!---variable for strong typing grid parameters -use platform_mod, only: r8_kind, r4_kind -implicit none -private - -! Include variable "version" to be written to log file. -#include -!----------------------------------------------------------------------- -! version is public so that write_version_number can be called for constants_mod -! by fms_init -public :: version - -real(r4_kind) :: realnumber !< dummy variable to use in HUGE initializations - -!! The small_fac parameter is used to alter the radius of the earth to allow one to -!! examine non-hydrostatic effects without the need to run full-earth high-resolution -!! simulations (<13km) that will tax hardware resources. -#ifdef SMALL_EARTH -#if defined(DCMIP) || (defined(HIWPP) && defined(SUPER_K)) - real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 120._r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90 -#elif defined(HIWPP) - real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 166.7_r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90 -#else - real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 10._r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90 -#endif -#else - real(r4_kind), public, parameter :: small_fac = 1._r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90 -#endif - -#ifdef GFS_PHYS -! SJL: the following are from fv3_gfsphysics/gfs_physics/physics/physcons.f90 -real(r4_kind), public, parameter :: RADIUS = 6.3712e+6_r8_kind * small_fac !< Radius of the Earth [m] -real(kind=r8_kind), public, parameter :: PI_8 = 3.1415926535897931_r8_kind !< Ratio of circle circumference to diameter [N/A] -real(r4_kind), public, parameter :: PI = 3.1415926535897931_r8_kind !< Ratio of circle circumference to diameter [N/A] -real(r4_kind), public, parameter :: OMEGA = 7.2921e-5_r8_kind / small_fac !< Rotation rate of the Earth [1/s] -real(r4_kind), public, parameter :: GRAV = 9.80665_r8_kind !< Acceleration due to gravity [m/s^2] -real(kind=r8_kind), public, parameter :: GRAV_8 = 9.80665_r8_kind !< Acceleration due to gravity [m/s^2] (REAL(KIND=8)) -real(r4_kind), public, parameter :: RDGAS = 287.05_r8_kind !< Gas constant for dry air [J/kg/deg] -real(r4_kind), public, parameter :: RVGAS = 461.50_r8_kind !< Gas constant for water vapor [J/kg/deg] -! Extra: -real(r4_kind), public, parameter :: HLV = 2.5e6_r8_kind !< Latent heat of evaporation [J/kg] -real(r4_kind), public, parameter :: HLF = 3.3358e5_r8_kind !< Latent heat of fusion [J/kg] -real(r4_kind), public, parameter :: con_cliq = 4.1855e+3_r8_kind !< spec heat H2O liq [J/kg/K] -real(r4_kind), public, parameter :: con_csol = 2.1060e+3_r8_kind !< spec heat H2O ice [J/kg/K] -real(r4_kind), public, parameter :: CP_AIR = 1004.6_r8_kind !< Specific heat capacity of dry air at constant pressure [J/kg/deg] -real(r4_kind), public, parameter :: KAPPA = RDGAS/CP_AIR !< RDGAS / CP_AIR [dimensionless] -real(r4_kind), public, parameter :: TFREEZE = 273.15_r8_kind !< Freezing temperature of fresh water [K] - -#else - -real(r4_kind), public, parameter :: RADIUS = 6371.0e+3_r8_kind * small_fac !< Radius of the Earth [m] -real(kind=8), public, parameter :: PI_8 = 3.14159265358979323846_r8_kind !< Ratio of circle circumference to diameter [N/A] -real(r4_kind), public, parameter :: PI = 3.14159265358979323846_r8_kind !< Ratio of circle circumference to diameter [N/A] -real(r4_kind), public, parameter :: OMEGA = 7.292e-5_r8_kind / small_fac !< Rotation rate of the Earth [1/s] -real(r4_kind), public, parameter :: GRAV = 9.80_r8_kind !< Acceleration due to gravity [m/s^2] -real(r4_kind), public, parameter :: RDGAS = 287.04_r8_kind !< Gas constant for dry air [J/kg/deg] -real(r4_kind), public, parameter :: RVGAS = 461.50_r8_kind !< Gas constant for water vapor [J/kg/deg] -! Extra: -real(r4_kind), public, parameter :: HLV = 2.500e6_r8_kind !< Latent heat of evaporation [J/kg] -real(r4_kind), public, parameter :: HLF = 3.34e5_r8_kind !< Latent heat of fusion [J/kg] -real(r4_kind), public, parameter :: KAPPA = 2.0_r8_kind/7.0_r8_kind !< RDGAS / CP_AIR [dimensionless] -real(r4_kind), public, parameter :: CP_AIR = RDGAS/KAPPA !< Specific heat capacity of dry air at constant pressure [J/kg/deg] -real(r4_kind), public, parameter :: TFREEZE = 273.16_r8_kind !< Freezing temperature of fresh water [K] -#endif - -real(r4_kind), public, parameter :: STEFAN = 5.6734e-8_r8_kind !< Stefan-Boltzmann constant [W/m^2/deg^4] - -real(r4_kind), public, parameter :: CP_VAPOR = 4.0_r8_kind*RVGAS !< Specific heat capacity of water vapor at constant pressure [J/kg/deg] -real(r4_kind), public, parameter :: CP_OCEAN = 3989.24495292815_r8_kind !< Specific heat capacity taken from McDougall (2002) - !! "Potential Enthalpy ..." [J/kg/deg] -real(r4_kind), public, parameter :: RHO0 = 1.035e3_r8_kind !< Average density of sea water [kg/m^3] -real(r4_kind), public, parameter :: RHO0R = 1.0_r8_kind/RHO0 !< Reciprocal of average density of sea water [m^3/kg] -real(r4_kind), public, parameter :: RHO_CP = RHO0*CP_OCEAN !< (kg/m^3)*(cal/kg/deg C)(joules/cal) = (joules/m^3/deg C) [J/m^3/deg] - -real(r4_kind), public, parameter :: ES0 = 1.0_r8_kind !< Humidity factor. Controls the humidity content of the atmosphere through - !! the Saturation Vapour Pressure expression when using DO_SIMPLE. [dimensionless] -real(r4_kind), public, parameter :: DENS_H2O = 1000._r8_kind !< Density of liquid water [kg/m^3] -real(r4_kind), public, parameter :: HLS = HLV + HLF !< Latent heat of sublimation [J/kg] - -real(r4_kind), public, parameter :: WTMAIR = 2.896440E+01_r8_kind !< Molecular weight of air [AMU] -real(r4_kind), public, parameter :: WTMH2O = WTMAIR*(RDGAS/RVGAS) !< Molecular weight of water [AMU] -real(r4_kind), public, parameter :: WTMOZONE = 47.99820_r8_kind !< Molecular weight of ozone [AMU] -real(r4_kind), public, parameter :: WTMC = 12.00000_r8_kind !< Molecular weight of carbon [AMU] -real(r4_kind), public, parameter :: WTMCO2 = 44.00995_r8_kind !< Molecular weight of carbon dioxide [AMU] -real(r4_kind), public, parameter :: WTMCH4 = 16.0425_r8_kind !< Molecular weight of methane [AMU] -real(r4_kind), public, parameter :: WTMO2 = 31.9988_r8_kind !< Molecular weight of molecular oxygen [AMU] -real(r4_kind), public, parameter :: WTMCFC11 = 137.3681_r8_kind !< Molecular weight of CFC-11 (CCl3F) [AMU] -real(r4_kind), public, parameter :: WTMCFC12 = 120.9135_r8_kind !< Molecular weight of CFC-21 (CCl2F2) [AMU] -real(r4_kind), public, parameter :: WTMN = 14.0067_r8_kind !< Molecular weight of Nitrogen [AMU] -real(r4_kind), public, parameter :: DIFFAC = 1.660000E+00_r8_kind !< Diffusivity factor [dimensionless] -real(r4_kind), public, parameter :: AVOGNO = 6.023000E+23_r8_kind !< Avogadro's number [atoms/mole] -real(r4_kind), public, parameter :: PSTD = 1.013250E+06_r8_kind !< Mean sea level pressure [dynes/cm^2] -real(r4_kind), public, parameter :: PSTD_MKS = 101325.0_r8_kind !< Mean sea level pressure [N/m^2] - -real(r4_kind), public, parameter :: SECONDS_PER_DAY = 8.640000E+04_r8_kind !< Seconds in a day [s] -real(r4_kind), public, parameter :: SECONDS_PER_HOUR = 3600._r8_kind !< Seconds in an hour [s] -real(r4_kind), public, parameter :: SECONDS_PER_MINUTE = 60._r8_kind !< Seconds in a minute [s] -real(r4_kind), public, parameter :: RAD_TO_DEG = 180._r8_kind/PI !< Degrees per radian [deg/rad] -real(r4_kind), public, parameter :: DEG_TO_RAD = PI/180._r8_kind !< Radians per degree [rad/deg] -real(r4_kind), public, parameter :: RADIAN = RAD_TO_DEG !< Equal to RAD_TO_DEG for backward compatability. [rad/deg] -real(r4_kind), public, parameter :: ALOGMIN = -50.0_r8_kind !< Minimum value allowed as argument to log function [N/A] -real(r4_kind), public, parameter :: EPSLN = 1.0e-40_r8_kind !< A small number to prevent divide by zero exceptions [N/A] - -real(r4_kind), public, parameter :: RADCON = ((1.0E+02*GRAV)/(1.0E+04*CP_AIR))*SECONDS_PER_DAY !< Factor used to convert flux divergence to - !! heating rate in degrees per day [deg sec/(cm day)] -real(r4_kind), public, parameter :: RADCON_MKS = (GRAV/CP_AIR)*SECONDS_PER_DAY !< Factor used to convert flux divergence to - !! heating rate in degrees per day [deg sec/(m day)] -real(r4_kind), public, parameter :: O2MIXRAT = 2.0953E-01_r8_kind !< Mixing ratio of molecular oxygen in air [dimensionless] -real(r4_kind), public, parameter :: RHOAIR = 1.292269_r8_kind !< Reference atmospheric density [kg/m^3] -real(r4_kind), public, parameter :: VONKARM = 0.40_r8_kind !< Von Karman constant [dimensionless] -real(r4_kind), public, parameter :: C2DBARS = 1.e-4_r8_kind !< Converts rho*g*z (in mks) to dbars: 1dbar = 10^4 (kg/m^3)(m/s^2)m [dbars] -real(r4_kind), public, parameter :: KELVIN = 273.15_r8_kind !< Degrees Kelvin at zero Celsius [K] - -public :: constants_init - -contains - -!> @brief dummy routine. -subroutine constants_init - -end subroutine constants_init - -end module constantsR4_mod -!> @} -! close documentation grouping diff --git a/constants4/fmsconstants4.F90 b/constants4/fmsconstants4.F90 deleted file mode 100644 index 5d7af83dbc..0000000000 --- a/constants4/fmsconstants4.F90 +++ /dev/null @@ -1,32 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS is free software: you can redistribute it and/or modify it under -!* the terms of the GNU Lesser General Public License as published by -!* the Free Software Foundation, either version 3 of the License, or (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -!* for more details. -!* -!* You should have received a copy of the GNU Lesser General Public -!* License along with FMS. If not, see . -!*********************************************************************** -!> @defgroup fmsconstants FMSconstants -!> @ingroup libfms -!> @brief Essentially a copy of @ref constants_mod for external usage alongside -!! @ref libfms. -!! -!> See @ref constants_mod for individual parameter information. -module FMSconstantsR4 - - !> rename to not conflict with any other version vars - use constantsR4_mod, version_constants => version - - implicit none - -end module FMSconstantsR4 diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index 8f19ed865b..faf1c4909a 100644 --- a/diag_manager/diag_axis.F90 +++ b/diag_manager/diag_axis.F90 @@ -113,7 +113,7 @@ MODULE diag_axis_mod INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, direction,& & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position ) CHARACTER(len=*), INTENT(in) :: name !< Short name for axis - CLASS(*), DIMENSION(:), INTENT(in) :: DATA !< Array of coordinate values + REAL, DIMENSION(:), INTENT(in) :: DATA !< Array of coordinate values CHARACTER(len=*), INTENT(in) :: units !< Units for the axis CHARACTER(len=*), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T") CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis. @@ -231,15 +231,7 @@ INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, directi ! Initialize Axes(diag_axis_init) Axes(diag_axis_init)%name = TRIM(name) - SELECT TYPE (DATA) - TYPE IS (real(kind=r4_kind)) - Axes(diag_axis_init)%data = DATA(1:axlen) - TYPE IS (real(kind=r8_kind)) - Axes(diag_axis_init)%data = real(DATA(1:axlen)) - CLASS DEFAULT - CALL error_mesg('diag_axis_mod::diag_axis_init',& - & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + Axes(diag_axis_init)%data = DATA(1:axlen) Axes(diag_axis_init)%units = units Axes(diag_axis_init)%length = axlen Axes(diag_axis_init)%set = set @@ -468,7 +460,7 @@ SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,& INTEGER, INTENT(out) :: direction !< Direction of data. (See @ref diag_axis_init for a description of !! allowed values) INTEGER, INTENT(out) :: edges !< Axis ID for the previously defined "edges axis". - CLASS(*), DIMENSION(:), INTENT(out) :: DATA !< Array of coordinate values for this axis. + REAL, DIMENSION(:), INTENT(out) :: DATA !< Array of coordinate values for this axis. INTEGER, INTENT(out), OPTIONAL :: num_attributes TYPE(diag_atttype), ALLOCATABLE, DIMENSION(:), INTENT(out), OPTIONAL :: attributes INTEGER, INTENT(out), OPTIONAL :: domain_position @@ -489,15 +481,7 @@ SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,& ! array data is too small. CALL error_mesg('diag_axis_mod::get_diag_axis', 'array data is too small', FATAL) ELSE - SELECT TYPE (DATA) - TYPE IS (real(kind=r4_kind)) - DATA(1:Axes(id)%length) = real(Axes(id)%data(1:Axes(id)%length), kind=r4_kind) - TYPE IS (real(kind=r8_kind)) - DATA(1:Axes(id)%length) = Axes(id)%data(1:Axes(id)%length) - CLASS DEFAULT - CALL error_mesg('diag_axis_mod::get_diag_axis',& - & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + DATA(1:Axes(id)%length) = Axes(id)%data(1:Axes(id)%length) END IF IF ( PRESENT(num_attributes) ) THEN num_attributes = Axes(id)%num_attributes diff --git a/diag_manager/diag_grid.F90 b/diag_manager/diag_grid.F90 index 12b9c9115f..d394332cfe 100644 --- a/diag_manager/diag_grid.F90 +++ b/diag_manager/diag_grid.F90 @@ -132,10 +132,10 @@ MODULE diag_grid_mod !! and before the first call to register the fields. SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE(domain2d), INTENT(in) :: domain !< The domain to which the grid data corresponds. - CLASS(*), INTENT(in), DIMENSION(:,:) :: glo_lat !< The latitude information for the grid tile. - CLASS(*), INTENT(in), DIMENSION(:,:) :: glo_lon !< The longitude information for the grid tile. - CLASS(*), INTENT(in), DIMENSION(:,:) :: aglo_lat !< The latitude information for the a-grid tile. - CLASS(*), INTENT(in), DIMENSION(:,:) :: aglo_lon !< The longitude information for the a-grid tile. + REAL, INTENT(in), DIMENSION(:,:) :: glo_lat !< The latitude information for the grid tile. + REAL, INTENT(in), DIMENSION(:,:) :: glo_lon !< The longitude information for the grid tile. + REAL, INTENT(in), DIMENSION(:,:) :: aglo_lat !< The latitude information for the a-grid tile. + REAL, INTENT(in), DIMENSION(:,:) :: aglo_lon !< The longitude information for the a-grid tile. INTEGER, DIMENSION(1) :: tile INTEGER :: ntiles @@ -254,67 +254,14 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) ! If we are on tile 4 or 5, we need to transpose the grid to get ! this to work. IF ( tile(1) == 4 .OR. tile(1) == 5 ) THEN - SELECT TYPE (aglo_lat) - TYPE IS (real(kind=r4_kind)) - diag_global_grid%aglo_lat = TRANSPOSE(aglo_lat) - TYPE IS (real(kind=r8_kind)) - diag_global_grid%aglo_lat = TRANSPOSE(real(aglo_lat)) - CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init',& - & 'The a-grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - - SELECT TYPE (aglo_lon) - TYPE IS (real(kind=r4_kind)) - diag_global_grid%aglo_lon = TRANSPOSE(aglo_lon) - TYPE IS (real(kind=r8_kind)) - diag_global_grid%aglo_lon = TRANSPOSE(real(aglo_lon)) - CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init',& - & 'The a-grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + diag_global_grid%aglo_lat = TRANSPOSE(aglo_lat) + diag_global_grid%aglo_lon = TRANSPOSE(aglo_lon) ELSE - SELECT TYPE (aglo_lat) - TYPE IS (real(kind=r4_kind)) - diag_global_grid%aglo_lat = aglo_lat - TYPE IS (real(kind=r8_kind)) - diag_global_grid%aglo_lat = real(aglo_lat) - CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init',& - & 'The a-grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - - SELECT TYPE (aglo_lon) - TYPE IS (real(kind=r4_kind)) - diag_global_grid%aglo_lon = aglo_lon - TYPE IS (real(kind=r8_kind)) - diag_global_grid%aglo_lon = real(aglo_lon) - CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init',& - & 'The a-grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + diag_global_grid%aglo_lat = aglo_lat + diag_global_grid%aglo_lon = aglo_lon END IF - - SELECT TYPE (glo_lat) - TYPE IS (real(kind=r4_kind)) - diag_global_grid%glo_lat = glo_lat - TYPE IS (real(kind=r8_kind)) - diag_global_grid%glo_lat = real(glo_lat) - CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init',& - & 'The grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - - SELECT TYPE (glo_lon) - TYPE IS (real(kind=r4_kind)) - diag_global_grid%glo_lon = glo_lon - TYPE IS (real(kind=r8_kind)) - diag_global_grid%glo_lon = real(glo_lon) - CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init',& - & 'The grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - + diag_global_grid%glo_lat = glo_lat + diag_global_grid%glo_lon = glo_lon diag_global_grid%dimI = i_dim diag_global_grid%dimJ = j_dim diag_global_grid%adimI = ai_dim diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index a38777e4f2..08933eaa10 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -329,6 +329,12 @@ MODULE diag_manager_mod MODULE PROCEDURE send_data_1d MODULE PROCEDURE send_data_2d MODULE PROCEDURE send_data_3d +#ifdef OVERLOAD_R8 + MODULE PROCEDURE send_data_0d_r8 + MODULE PROCEDURE send_data_1d_r8 + MODULE PROCEDURE send_data_2d_r8 + MODULE PROCEDURE send_data_3d_r8 +#endif END INTERFACE !> @brief Register a diagnostic field for a given module @@ -368,8 +374,8 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, CHARACTER(len=*), INTENT(in) :: module_name, field_name TYPE(time_type), OPTIONAL, INTENT(in) :: init_time CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name - CLASS(*), OPTIONAL, INTENT(in) :: missing_value - CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range + REAL, OPTIONAL, INTENT(in) :: missing_value + REAL, DIMENSION(2), OPTIONAL, INTENT(in) :: RANGE LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg INTEGER, OPTIONAL, INTENT(in) :: area, volume @@ -377,14 +383,6 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, IF ( PRESENT(err_msg) ) err_msg = '' - ! Fatal error if range is present and its extent is not 2. - IF ( PRESENT(range) ) THEN - IF ( SIZE(range) .NE. 2 ) THEN - ! extent of range should be 2 - CALL error_mesg ('diag_manager_mod::register_diag_field', 'extent of range should be 2', FATAL) - END IF - END IF - IF ( PRESENT(init_time) ) THEN register_diag_field_scalar = register_diag_field_array(module_name, field_name,& & (/null_axis_id/), init_time,long_name, units, missing_value, range, & @@ -406,8 +404,7 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t INTEGER, INTENT(in) :: axes(:) TYPE(time_type), INTENT(in) :: init_time CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name - CLASS(*), OPTIONAL, INTENT(in) :: missing_value - CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range + REAL, OPTIONAL, INTENT(in) :: missing_value, RANGE(2) LOGICAL, OPTIONAL, INTENT(in) :: mask_variant,verbose LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg @@ -445,14 +442,6 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t IF ( PRESENT(err_msg) ) err_msg = '' - ! Fatal error if range is present and its extent is not 2. - IF ( PRESENT(range) ) THEN - IF ( SIZE(range) .NE. 2 ) THEN - ! extent of range should be 2 - CALL error_mesg ('diag_manager_mod::register_diag_field', 'extent of range should be 2', FATAL) - END IF - END IF - ! Call register static, then set static back to false register_diag_field_array = register_static_field(module_name, field_name, axes,& & long_name, units, missing_value, range, mask_variant1, standard_name=standard_name,& @@ -602,8 +591,8 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, CHARACTER(len=*), INTENT(in) :: module_name, field_name INTEGER, DIMENSION(:), INTENT(in) :: axes CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name - CLASS(*), OPTIONAL, INTENT(in) :: missing_value - CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range + REAL, OPTIONAL, INTENT(in) :: missing_value + REAL, DIMENSION(2), OPTIONAL, INTENT(in) :: range LOGICAL, OPTIONAL, INTENT(in) :: mask_variant LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged @@ -616,8 +605,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated with this field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the modeling_realm attribute - REAL :: missing_value_use !< Local copy of missing_value - REAL, DIMENSION(2) :: range_use !< Local copy of range + REAL :: missing_value_use INTEGER :: field, num_axes, j, out_num, k INTEGER, DIMENSION(3) :: siz, local_siz, local_start, local_end ! indices of local domain of global axes INTEGER :: tile, file_num @@ -636,15 +624,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, IF ( use_cmor ) THEN missing_value_use = CMOR_MISSING_VALUE ELSE - SELECT TYPE (missing_value) - TYPE IS (real(kind=r4_kind)) - missing_value_use = missing_value - TYPE IS (real(kind=r8_kind)) - missing_value_use = real(missing_value) - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::register_static_field',& - & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + missing_value_use = missing_value END IF END IF @@ -672,14 +652,6 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, allow_log = .TRUE. END IF - ! Fatal error if range is present and its extent is not 2. - IF ( PRESENT(range) ) THEN - IF ( SIZE(range) .NE. 2 ) THEN - ! extent of range should be 2 - CALL error_mesg ('diag_manager_mod::register_static_field', 'extent of range should be 2', FATAL) - END IF - END IF - ! Namelist do_diag_field_log is by default false. Thus to log the ! registration of the data field, but the OPTIONAL parameter ! do_not_log == .FALSE. and the namelist variable @@ -799,18 +771,9 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, END IF IF ( PRESENT(range) ) THEN - SELECT TYPE (range) - TYPE IS (real(kind=r4_kind)) - range_use = range - TYPE IS (real(kind=r8_kind)) - range_use = real(range) - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::register_static_field',& - & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - input_fields(field)%range = range_use + input_fields(field)%range = range ! don't use the range if it is not a valid range - input_fields(field)%range_present = range_use(2) .gt. range_use(1) + input_fields(field)%range_present = range(2) .gt. range(1) ELSE input_fields(field)%range = (/ 1., 0. /) input_fields(field)%range_present = .FALSE. @@ -1276,45 +1239,35 @@ END SUBROUTINE add_associated_files !> @return true if send is successful LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg) INTEGER, INTENT(in) :: diag_field_id - CLASS(*), INTENT(in) :: field + REAL, INTENT(in) :: field TYPE(time_type), INTENT(in), OPTIONAL :: time CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - REAL :: field_out(1, 1, 1) !< Local copy of field + REAL :: field_out(1, 1, 1) ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN send_data_0d = .FALSE. RETURN END IF - ! First copy the data to a three d array with last element 1 - SELECT TYPE (field) - TYPE IS (real(kind=r4_kind)) - field_out(1, 1, 1) = field - TYPE IS (real(kind=r8_kind)) - field_out(1, 1, 1) = real(field) - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_0d',& - & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - + field_out(1, 1, 1) = field send_data_0d = send_data_3d(diag_field_id, field_out, time, err_msg=err_msg) END FUNCTION send_data_0d !> @return true if send is successful LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) INTEGER, INTENT(in) :: diag_field_id - CLASS(*), DIMENSION(:), INTENT(in) :: field - CLASS(*), INTENT(in), OPTIONAL :: weight - CLASS(*), INTENT(in), DIMENSION(:), OPTIONAL :: rmask + REAL, DIMENSION(:), INTENT(in) :: field + REAL, INTENT(in), OPTIONAL :: weight + REAL, INTENT(in), DIMENSION(:), OPTIONAL :: rmask TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, ie_in LOGICAL, INTENT(in), DIMENSION(:), OPTIONAL :: mask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out !< Local copy of field - LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out !< Local copy of mask + REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out + LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN @@ -1323,15 +1276,7 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie END IF ! First copy the data to a three d array with last element 1 - SELECT TYPE (field) - TYPE IS (real(kind=r4_kind)) - field_out(:, 1, 1) = field - TYPE IS (real(kind=r8_kind)) - field_out(:, 1, 1) = real(field) - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_1d',& - & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + field_out(:, 1, 1) = field ! Default values for mask IF ( PRESENT(mask) ) THEN @@ -1340,18 +1285,7 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie mask_out = .TRUE. END IF - IF ( PRESENT(rmask) ) THEN - SELECT TYPE (rmask) - TYPE IS (real(kind=r4_kind)) - WHERE (rmask < 0.5_r4_kind) mask_out(:, 1, 1) = .FALSE. - TYPE IS (real(kind=r8_kind)) - WHERE (rmask < 0.5_r8_kind) mask_out(:, 1, 1) = .FALSE. - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_1d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - END IF - + IF ( PRESENT(rmask) ) WHERE (rmask < 0.5) mask_out(:, 1, 1) = .FALSE. IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& @@ -1374,16 +1308,16 @@ END FUNCTION send_data_1d LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & & mask, rmask, ie_in, je_in, weight, err_msg) INTEGER, INTENT(in) :: diag_field_id - CLASS(*), INTENT(in), DIMENSION(:,:) :: field - CLASS(*), INTENT(in), OPTIONAL :: weight + REAL, INTENT(in), DIMENSION(:,:) :: field + REAL, INTENT(in), OPTIONAL :: weight TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ie_in, je_in LOGICAL, INTENT(in), DIMENSION(:,:), OPTIONAL :: mask - CLASS(*), INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask + REAL, INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out !< Local copy of field - LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out !< Local copy of mask + REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out + LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN @@ -1392,15 +1326,7 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & END IF ! First copy the data to a three d array with last element 1 - SELECT TYPE (field) - TYPE IS (real(kind=r4_kind)) - field_out(:, :, 1) = field - TYPE IS (real(kind=r8_kind)) - field_out(:, :, 1) = real(field) - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_2d',& - & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + field_out(:, :, 1) = field ! Default values for mask IF ( PRESENT(mask) ) THEN @@ -1409,18 +1335,7 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & mask_out = .TRUE. END IF - IF ( PRESENT(rmask) ) THEN - SELECT TYPE (rmask) - TYPE IS (real(kind=r4_kind)) - WHERE ( rmask < 0.5_r4_kind ) mask_out(:, :, 1) = .FALSE. - TYPE IS (real(kind=r8_kind)) - WHERE ( rmask < 0.5_r8_kind ) mask_out(:, :, 1) = .FALSE. - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_2d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - END IF - + IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) mask_out(:, :, 1) = .FALSE. IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1, mask=mask_out,& & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) @@ -1430,16 +1345,168 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & END IF END FUNCTION send_data_2d +#ifdef OVERLOAD_R8 + + !> @return true if send is successful + LOGICAL FUNCTION send_data_0d_r8(diag_field_id, field, time, err_msg) + INTEGER, INTENT(in) :: diag_field_id + REAL(r8_kind), INTENT(in) :: field + TYPE(time_type), INTENT(in), OPTIONAL :: time + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + + REAL(r8_kind) :: field_out(1, 1, 1) + + ! If diag_field_id is < 0 it means that this field is not registered, simply return + IF ( diag_field_id <= 0 ) THEN + send_data_0d_r8 = .FALSE. + RETURN + END IF + ! First copy the data to a three d array with last element 1 + field_out(1, 1, 1) = field + send_data_0d_r8 = send_data_3d_r8(diag_field_id, field_out, time, err_msg=err_msg) + END FUNCTION send_data_0d_r8 + + !> @return true if send is successful + LOGICAL FUNCTION send_data_1d_r8(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) + INTEGER, INTENT(in) :: diag_field_id + REAL(r8_kind), DIMENSION(:), INTENT(in) :: field + REAL, INTENT(in), OPTIONAL :: weight + REAL, INTENT(in), DIMENSION(:), OPTIONAL :: rmask + TYPE (time_type), INTENT(in), OPTIONAL :: time + INTEGER, INTENT(in), OPTIONAL :: is_in, ie_in + LOGICAL, INTENT(in), DIMENSION(:), OPTIONAL :: mask + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + + REAL(r8_kind), DIMENSION(SIZE(field(:)), 1, 1) :: field_out + LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out + + ! If diag_field_id is < 0 it means that this field is not registered, simply return + IF ( diag_field_id <= 0 ) THEN + send_data_1d_r8 = .FALSE. + RETURN + END IF + + ! First copy the data to a three d array with last element 1 + field_out(:, 1, 1) = field + + ! Default values for mask + IF ( PRESENT(mask) ) THEN + mask_out(:, 1, 1) = mask + ELSE + mask_out = .TRUE. + END IF + + IF ( PRESENT(rmask) ) WHERE (rmask < 0.5) mask_out(:, 1, 1) = .FALSE. + IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN + IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN + send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& + & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) + ELSE + send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, mask=mask_out,& + & weight=weight, err_msg=err_msg) + END IF + ELSE + IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN + send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& + & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) + ELSE + send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, weight=weight, err_msg=err_msg) + END IF + END IF + END FUNCTION send_data_1d_r8 + !> @return true if send is successful + LOGICAL FUNCTION send_data_2d_r8(diag_field_id, field, time, is_in, js_in, & + & mask, rmask, ie_in, je_in, weight, err_msg) + INTEGER, INTENT(in) :: diag_field_id + REAL(r8_kind), INTENT(in), DIMENSION(:,:) :: field + REAL, INTENT(in), OPTIONAL :: weight + TYPE (time_type), INTENT(in), OPTIONAL :: time + INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ie_in, je_in + LOGICAL, INTENT(in), DIMENSION(:,:), OPTIONAL :: mask + REAL, INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + + REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out + LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out + + ! If diag_field_id is < 0 it means that this field is not registered, simply return + IF ( diag_field_id <= 0 ) THEN + send_data_2d_r8 = .FALSE. + RETURN + END IF + + ! First copy the data to a three d array with last element 1 + field_out(:, :, 1) = field + + ! Default values for mask + IF ( PRESENT(mask) ) THEN + mask_out(:, :, 1) = mask + ELSE + mask_out = .TRUE. + END IF + + IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) mask_out(:, :, 1) = .FALSE. + IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN + send_data_2d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1, mask=mask_out,& + & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) + ELSE + send_data_2d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& + & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) + END IF + END FUNCTION send_data_2d_r8 + + !> @return true if send is successful + LOGICAL FUNCTION send_data_3d_r8(diag_field_id, field, time, is_in, js_in, ks_in, & + & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) + INTEGER, INTENT(in) :: diag_field_id + REAL(r8_kind), INTENT(in), DIMENSION(:,:,:) :: field + REAL, INTENT(in), OPTIONAL :: weight + TYPE (time_type), INTENT(in), OPTIONAL :: time + INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in + LOGICAL, INTENT(in), DIMENSION(:,:,:), OPTIONAL :: mask + REAL, INTENT(in), DIMENSION(:,:,:),OPTIONAL :: rmask + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + + REAL, DIMENSION(SIZE(field,1),SIZE(field,2),size(field,3)) :: field_out + LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),size(field,3)) :: mask_out + + ! If diag_field_id is < 0 it means that this field is not registered, simply return + IF ( diag_field_id <= 0 ) THEN + send_data_3d_r8 = .FALSE. + RETURN + END IF + + ! First copy the data to a three d array with last element 1 + field_out = field + + ! Default values for mask + IF ( PRESENT(mask) ) THEN + mask_out = mask + ELSE + mask_out = .TRUE. + END IF + + IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) mask_out = .FALSE. + IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN + send_data_3d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=ks_in, mask=mask_out,& + & ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + ELSE + send_data_3d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=ks_in,& + & ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + END IF + END FUNCTION send_data_3d_r8 +#endif + !> @return true if send is successful LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) INTEGER, INTENT(in) :: diag_field_id - CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field - CLASS(*), INTENT(in), OPTIONAL :: weight + REAL, DIMENSION(:,:,:), INTENT(in) :: field + REAL, INTENT(in), OPTIONAL :: weight TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask - CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask + REAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg REAL :: weight1 @@ -1473,8 +1540,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CHARACTER(len=256) :: err_msg_local CHARACTER(len=128) :: error_string, error_string1 - REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field - ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN send_data_3d = .FALSE. @@ -1497,23 +1562,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & !!$ first_send_data_call = .FALSE. !!$ END IF - ! First copy the data to a three d array - ALLOCATE(field_out(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status) - IF ( status .NE. 0 ) THEN - WRITE (err_msg_local, FMT='("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')& - & SIZE(field,1), SIZE(field,2), SIZE(field,3), status - IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN - END IF - SELECT TYPE (field) - TYPE IS (real(kind=r4_kind)) - field_out = field - TYPE IS (real(kind=r8_kind)) - field_out = real(field) - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - ! oor_mask is only used for checking out of range values. ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status) IF ( status .NE. 0 ) THEN @@ -1527,18 +1575,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ELSE oor_mask = .TRUE. END IF - - IF ( PRESENT(rmask) ) THEN - SELECT TYPE (rmask) - TYPE IS (real(kind=r4_kind)) - WHERE ( rmask < 0.5_r4_kind ) oor_mask = .FALSE. - TYPE IS (real(kind=r8_kind)) - WHERE ( rmask < 0.5_r8_kind ) oor_mask = .FALSE. - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - END IF + IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) oor_mask = .FALSE. ! send_data works in either one or another of two modes. ! 1. Input field is a window (e.g. FMS physics) @@ -1554,7 +1591,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( PRESENT(ie_in) ) THEN IF ( .NOT.PRESENT(is_in) ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'ie_in present without is_in', err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1562,7 +1598,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN IF ( fms_error_handler('diag_manager_modsend_data_3d',& & 'is_in and ie_in present, but js_in present without je_in', err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1571,7 +1606,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( PRESENT(je_in) ) THEN IF ( .NOT.PRESENT(js_in) ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'je_in present without js_in', err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1579,7 +1613,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d',& & 'js_in and je_in present, but is_in present without ie_in', err_msg)) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1605,7 +1638,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & twohi = n1-(ie-is+1) IF ( MOD(twohi,2) /= 0 ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in first dimension', err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1613,7 +1645,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & twohj = n2-(je-js+1) IF ( MOD(twohj,2) /= 0 ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in second dimension', err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1638,15 +1669,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ! weight is for time averaging where each time level may has a different weight IF ( PRESENT(weight) ) THEN - SELECT TYPE (weight) - TYPE IS (real(kind=r4_kind)) - weight1 = weight - TYPE IS (real(kind=r8_kind)) - weight1 = real(weight) - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The weight is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + weight1 = weight ELSE weight1 = 1. END IF @@ -1675,13 +1698,13 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & WRITE (error_string, '("[",ES14.5E3,",",ES14.5E3,"]")')& & input_fields(diag_field_id)%range(1:2) WRITE (error_string1, '("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')& - & MINVAL(field_out(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)),& - & MAXVAL(field_out(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)) + & MINVAL(field(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)),& + & MAXVAL(field(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)) IF ( missvalue_present ) THEN IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.& - & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.& - & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.& - & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) ) THEN + & ((field(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.& + & field(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.& + & field(f1:f2,f3:f4,ks:ke) .NE. missvalue)) ) THEN ! ! A value for in field (Min: , Max: ) ! is outside the range [,] and not equal to the missing @@ -1698,8 +1721,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF ELSE IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.& - & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.& - & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) ) THEN + & (field(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.& + & field(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) ) THEN ! ! A value for in field (Min: , Max: ) ! is outside the range [,]. @@ -1749,7 +1772,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & time_min = output_fields(out_num)%time_min ! Sum output over time interval time_sum = output_fields(out_num)%time_sum - IF ( output_fields(out_num)%total_elements > SIZE(field_out(f1:f2,f3:f4,ks:ke)) ) THEN + IF ( output_fields(out_num)%total_elements > SIZE(field(f1:f2,f3:f4,ks:ke)) ) THEN output_fields(out_num)%phys_window = .TRUE. ELSE output_fields(out_num)%phys_window = .FALSE. @@ -1793,7 +1816,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & TRIM(output_fields(out_num)%output_name) IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& & ', time must be present when output frequency = EVERY_TIME', err_msg)) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1806,7 +1828,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & TRIM(output_fields(out_num)%output_name) IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& & ', time must be present for nonstatic field', err_msg)) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1826,7 +1847,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & TRIM(output_fields(out_num)%output_name) IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& & ' is skipped one time level in output data', err_msg)) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1838,7 +1858,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//TRIM(error_string)//& & ', write EMPTY buffer', err_msg)) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1853,7 +1872,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CALL check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1869,7 +1887,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & TRIM(output_fields(out_num)%output_name) IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& & ', regional output NOT supported with mask_variant', err_msg)) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1884,7 +1901,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1900,11 +1916,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value) + & (field(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & field_out(i-is+1+hi, j-js+1+hj, k) * weight1 + & field(i-is+1+hi, j-js+1+hj, k) * weight1 END IF output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1 @@ -1920,11 +1936,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k)*weight1 + & field(i-is+1+hi,j-js+1+hj,k)*weight1 END IF output_fields(out_num)%counter(i-hi,j-hj,k,sample) =& &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1 @@ -1944,11 +1960,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & (field_out(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value) + & (field(i-is+1+hi, j-js+1+hj, k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & field_out(i-is+1+hi, j-js+1+hj, k) * weight1 + & field(i-is+1+hi, j-js+1+hj, k) * weight1 END IF output_fields(out_num)%counter(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%counter(i-hi,j-hj,k1,sample) + weight1 @@ -1964,11 +1980,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k)*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k)*weight1 + & field(i-is+1+hi,j-js+1+hj,k)*weight1 END IF output_fields(out_num)%counter(i-hi,j-hj,k,sample) =& &output_fields(out_num)%counter(i-hi,j-hj,k,sample) + weight1 @@ -1985,7 +2001,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & TRIM(output_fields(out_num)%output_name) IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& & ', variable mask but no missing value defined', err_msg)) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1996,7 +2011,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & TRIM(output_fields(out_num)%output_name) IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//TRIM(error_string)//& & ', variable mask but no mask given', err_msg)) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -2017,11 +2031,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i1,j1,k1,sample) =& & output_fields(out_num)%buffer(i1,j1,k1,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i1,j1,k1,sample) =& & output_fields(out_num)%buffer(i1,j1,k1,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue @@ -2043,11 +2057,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i1,j1,k1,sample) =& & output_fields(out_num)%buffer(i1,j1,k1,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i1,j1,k1,sample) =& & output_fields(out_num)%buffer(i1,j1,k1,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue @@ -2078,11 +2092,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue @@ -2100,11 +2114,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue @@ -2120,7 +2134,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -2134,11 +2147,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue @@ -2155,11 +2168,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue @@ -2203,10 +2216,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & j1 = j-l_start(2)-hj+1 IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample)+ & - & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample)+ & - & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 END IF END IF END DO @@ -2220,10 +2233,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & j1 = j-l_start(2)-hj+1 IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample)+ & - & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample)+ & - & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 END IF END IF END DO @@ -2248,11 +2261,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +& - & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) + & (field(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +& - & field_out(f1:f2,f3:f4,ksr:ker)*weight1 + & field(f1:f2,f3:f4,ksr:ker)*weight1 END IF ELSE !$OMP CRITICAL @@ -2261,11 +2274,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +& - & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) + & (field(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) +& - & field_out(f1:f2,f3:f4,ksr:ker)*weight1 + & field(f1:f2,f3:f4,ksr:ker)*weight1 END IF !$OMP END CRITICAL END IF @@ -2275,7 +2288,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '') THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -2285,22 +2297,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& - & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) + & (field(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& - & field_out(f1:f2,f3:f4,ks:ke)*weight1 + & field(f1:f2,f3:f4,ks:ke)*weight1 END IF ELSE !$OMP CRITICAL IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& - & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) + & (field(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& - & field_out(f1:f2,f3:f4,ks:ke)*weight1 + & field(f1:f2,f3:f4,ks:ke)*weight1 END IF !$OMP END CRITICAL END IF @@ -2321,15 +2333,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj) THEN i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 - IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i1,j1,k1,sample) =& & output_fields(out_num)%buffer(i1,j1,k1,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i1,j1,k1,sample) =& & output_fields(out_num)%buffer(i1,j1,k1,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue @@ -2347,15 +2359,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj) THEN i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 - IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i1,j1,k1,sample) =& & output_fields(out_num)%buffer(i1,j1,k1,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i1,j1,k1,sample) =& & output_fields(out_num)%buffer(i1,j1,k1,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue @@ -2379,7 +2391,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & outer0: DO k = l_start(3), l_end(3) DO j=l_start(2)+hj, l_end(2)+hj DO i=l_start(1)+hi, l_end(1)+hi - IF ( field_out(i,j,k) /= missvalue ) THEN + IF ( field(i,j,k) /= missvalue ) THEN output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1 EXIT outer0 END IF @@ -2396,15 +2408,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & k1 = k - ksr + 1 DO j=js, je DO i=is, ie - IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue @@ -2420,15 +2432,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & k1 = k - ksr + 1 DO j=js, je DO i=is, ie - IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i-hi,j-hj,k1,sample) = missvalue @@ -2443,7 +2455,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & k1=k-ksr+1 DO j=f3, f4 DO i=f1, f2 - IF ( field_out(i,j,k) /= missvalue ) THEN + IF ( field(i,j,k) /= missvalue ) THEN output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1 EXIT outer3 END IF @@ -2457,7 +2469,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -2467,15 +2478,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & DO k=ks, ke DO j=js, je DO i=is, ie - IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue @@ -2488,15 +2499,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & DO k=ks, ke DO j=js, je DO i=is, ie - IF ( field_out(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN + IF ( field(i-is+1+hi,j-js+1+hj,k) /= missvalue ) THEN IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,k) * weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i-hi,j-hj,k,sample) =& & output_fields(out_num)%buffer(i-hi,j-hj,k,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,k) * weight1 + & field(i-is+1+hi,j-js+1+hj,k) * weight1 END IF ELSE output_fields(out_num)%buffer(i-hi,j-hj,k,sample) = missvalue @@ -2510,7 +2521,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & outer1: DO k=ks, ke DO j=f3, f4 DO i=f1, f2 - IF ( field_out(i,j,k) /= missvalue ) THEN + IF ( field(i,j,k) /= missvalue ) THEN output_fields(out_num)%count_0d(sample) = output_fields(out_num)%count_0d(sample) + weight1 EXIT outer1 END IF @@ -2529,10 +2540,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & j1= j-l_start(2)-hj+1 IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 END IF END IF END DO @@ -2546,10 +2557,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & j1= j-l_start(2)-hj+1 IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample) +& - & (field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) + & (field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(i1,j1,:,sample)= output_fields(out_num)%buffer(i1,j1,:,sample) +& - & field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 + & field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3))*weight1 END IF END IF END DO @@ -2575,22 +2586,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + & - & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) + & (field(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + & - & field_out(f1:f2,f3:f4,ksr:ker)*weight1 + & field(f1:f2,f3:f4,ksr:ker)*weight1 END IF ELSE !$OMP CRITICAL IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + & - & (field_out(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) + & (field(f1:f2,f3:f4,ksr:ker)*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + & - & field_out(f1:f2,f3:f4,ksr:ker)*weight1 + & field(f1:f2,f3:f4,ksr:ker)*weight1 END IF !$OMP END CRITICAL END IF @@ -2600,7 +2611,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -2610,22 +2620,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& - & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) + & (field(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& - & field_out(f1:f2,f3:f4,ks:ke)*weight1 + & field(f1:f2,f3:f4,ks:ke)*weight1 END IF ELSE !$OMP CRITICAL IF ( pow_value /= 1 ) THEN output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& - & (field_out(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) + & (field(f1:f2,f3:f4,ks:ke)*weight1)**(pow_value) ELSE output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) =& & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) +& - & field_out(f1:f2,f3:f4,ks:ke)*weight1 + & field(f1:f2,f3:f4,ks:ke)*weight1 END IF !$OMP END CRITICAL END IF @@ -2657,8 +2667,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND.& - & field_out(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample)) THEN - output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k) + & field(i-is+1+hi,j-js+1+hj,k)>output_fields(out_num)%buffer(i1,j1,k1,sample)) THEN + output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k) END IF END IF END DO @@ -2669,23 +2679,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ksr = l_start(3) ker = l_end(3) WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND. & - & field_out(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample))& - & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker) + & field(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample))& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker) ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF END IF END IF WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND.& - & field_out(f1:f2,f3:f4,ks:ke)>output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample))& - & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke) + & field(f1:f2,f3:f4,ks:ke)>output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample))& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke) END IF ELSE IF ( need_compute ) THEN @@ -2696,8 +2705,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN i1 = i-l_start(1)-hi+1 j1 = j-l_start(2)-hj+1 - IF ( field_out(i-is+1+hi,j-js+1+hj,k) > output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN - output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k) + IF ( field(i-is+1+hi,j-js+1+hj,k) > output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN + output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k) END IF END IF END DO @@ -2707,22 +2716,21 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ELSE IF ( reduced_k_range ) THEN ksr = l_start(3) ker = l_end(3) - WHERE ( field_out(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) & - & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker) + WHERE ( field(f1:f2,f3:f4,ksr:ker) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) & + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker) ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF END IF END IF - WHERE ( field_out(f1:f2,f3:f4,ks:ke) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) & - & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke) + WHERE ( field(f1:f2,f3:f4,ks:ke) > output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) & + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke) END IF END IF output_fields(out_num)%count_0d(sample) = 1 @@ -2737,8 +2745,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & i1 = i-l_start(1)-hi+1 j1 = j-l_start(2)-hj+1 IF ( mask(i-is+1+hi,j-js+1+hj,k) .AND.& - & field_out(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN - output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k) + & field(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN + output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k) END IF END IF END DO @@ -2749,23 +2757,22 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ksr= l_start(3) ker= l_end(3) WHERE ( mask(f1:f2,f3:f4,ksr:ker) .AND.& - & field_out(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample)) & - & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker) + & field(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample)) & + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker) ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF END IF END IF WHERE ( mask(f1:f2,f3:f4,ks:ke) .AND.& - & field_out(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) & - & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke) + & field(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) ) & + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke) END IF ELSE IF ( need_compute ) THEN @@ -2776,8 +2783,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj) THEN i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 - IF ( field_out(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN - output_fields(out_num)%buffer(i1,j1,k1,sample) = field_out(i-is+1+hi,j-js+1+hj,k) + IF ( field(i-is+1+hi,j-js+1+hj,k) < output_fields(out_num)%buffer(i1,j1,k1,sample) ) THEN + output_fields(out_num)%buffer(i1,j1,k1,sample) = field(i-is+1+hi,j-js+1+hj,k) END IF END IF END DO @@ -2787,22 +2794,21 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ELSE IF ( reduced_k_range ) THEN ksr= l_start(3) ker= l_end(3) - WHERE ( field_out(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) & - output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker) + WHERE ( field(f1:f2,f3:f4,ksr:ker) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) ) & + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker) ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF END IF END IF - WHERE ( field_out(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )& - & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke) + WHERE ( field(f1:f2,f3:f4,ks:ke) < output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) )& + & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke) END IF END IF output_fields(out_num)%count_0d(sample) = 1 @@ -2819,7 +2825,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( mask(i-is+1+hi,j-js+1+hj,k) ) THEN output_fields(out_num)%buffer(i1,j1,k1,sample) = & output_fields(out_num)%buffer(i1,j1,k1,sample) + & - field_out(i-is+1+hi,j-js+1+hj,k) + field(i-is+1+hi,j-js+1+hj,k) END IF END IF END DO @@ -2831,14 +2837,13 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ker= l_end(3) output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = & & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + & - & field_out(f1:f2,f3:f4,ksr:ker) + & field(f1:f2,f3:f4,ksr:ker) ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -2847,7 +2852,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & WHERE ( mask(f1:f2,f3:f4,ks:ke) ) & & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = & & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + & - & field_out(f1:f2,f3:f4,ks:ke) + & field(f1:f2,f3:f4,ks:ke) END IF ELSE IF ( need_compute ) THEN @@ -2860,7 +2865,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & j1= j-l_start(2)-hj+1 output_fields(out_num)%buffer(i1,j1,k1,sample) = & & output_fields(out_num)%buffer(i1,j1,k1,sample) + & - & field_out(i-is+1+hi,j-js+1+hj,k) + & field(i-is+1+hi,j-js+1+hj,k) END IF END DO END DO @@ -2870,14 +2875,13 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ker= l_end(3) output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = & & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) + & - & field_out(f1:f2,f3:f4,ksr:ker) + & field(f1:f2,f3:f4,ksr:ker) ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -2885,7 +2889,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = & & output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) + & - & field_out(f1:f2,f3:f4,ks:ke) + & field(f1:f2,f3:f4,ks:ke) END IF END IF output_fields(out_num)%count_0d(sample) = 1 @@ -2897,7 +2901,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN i1 = i-l_start(1)-hi+1 j1 = j-l_start(2)-hj+1 - output_fields(out_num)%buffer(i1,j1,:,sample) = field_out(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3)) + output_fields(out_num)%buffer(i1,j1,:,sample) = field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3)) END IF END DO END DO @@ -2905,20 +2909,19 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ELSE IF ( reduced_k_range ) THEN ksr = l_start(3) ker = l_end(3) - output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field_out(f1:f2,f3:f4,ksr:ker) + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,:,sample) = field(f1:f2,f3:f4,ksr:ker) ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(out_num, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL check_out_of_bounds(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF END IF END IF - output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field_out(f1:f2,f3:f4,ks:ke) + output_fields(out_num)%buffer(is-hi:ie-hi,js-hj:je-hj,ks:ke,sample) = field(f1:f2,f3:f4,ks:ke) END IF IF ( PRESENT(mask) .AND. missvalue_present ) THEN @@ -2965,7 +2968,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CALL check_bounds_are_exact_static(out_num, diag_field_id, err_msg=err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg)) THEN - DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -2975,97 +2977,45 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ! If rmask and missing value present, then insert missing value IF ( PRESENT(rmask) .AND. missvalue_present ) THEN IF ( need_compute ) THEN - SELECT TYPE (rmask) - TYPE IS (real(kind=r4_kind)) - DO k = l_start(3), l_end(3) - k1 = k - l_start(3) + 1 - DO j = js, je - DO i = is, ie - IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN - i1 = i-l_start(1)-hi+1 - j1 = j-l_start(2)-hj+1 - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) & - & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue - END IF - END DO - END DO - END DO - TYPE IS (real(kind=r8_kind)) - DO k = l_start(3), l_end(3) - k1 = k - l_start(3) + 1 - DO j = js, je - DO i = is, ie - IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN - i1 = i-l_start(1)-hi+1 - j1 = j-l_start(2)-hj+1 - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) & - & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue - END IF - END DO + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5 ) & + & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue + END IF END DO END DO - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + END DO ELSE IF ( reduced_k_range ) THEN ksr= l_start(3) ker= l_end(3) - SELECT TYPE (rmask) - TYPE IS (real(kind=r4_kind)) - DO k= ksr, ker - k1 = k - ksr + 1 - DO j=js, je - DO i=is, ie - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) & - & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue - END DO + DO k= ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5 ) & + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue END DO END DO - TYPE IS (real(kind=r8_kind)) - DO k= ksr, ker - k1 = k - ksr + 1 - DO j=js, je - DO i=is, ie - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) & - & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue - END DO - END DO - END DO - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + END DO ELSE - SELECT TYPE (rmask) - TYPE IS (real(kind=r4_kind)) - DO k=ks, ke - DO j=js, je - DO i=is, ie - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) & - & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue - END DO + DO k=ks, ke + DO j=js, je + DO i=is, ie + IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5 ) & + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue END DO END DO - TYPE IS (real(kind=r8_kind)) - DO k=ks, ke - DO j=js, je - DO i=is, ie - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) & - & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue - END DO - END DO - END DO - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT + END DO END IF END IF END DO num_out_fields - DEALLOCATE(field_out) DEALLOCATE(oor_mask) END FUNCTION send_data_3d diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 10598cedf1..618702c30e 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -632,8 +632,8 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field. CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field. - CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. - CLASS(*), DIMENSION(:), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field. + REAL, OPTIONAL, INTENT(in) :: missing_value !< Missing value value. + REAL, DIMENSION(2), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field. LOGICAL, OPTIONAL, INTENT(in) :: dynamic !< .TRUE. if field is not static. ! ---- local vars @@ -643,20 +643,10 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& CHARACTER(len=1) :: sep = '|' CHARACTER(len=256) :: axis_name, axes_list INTEGER :: i - REAL :: missing_value_use !< Local copy of missing_value - REAL, DIMENSION(2) :: range_use !< Local copy of range IF ( .NOT.do_diag_field_log ) RETURN IF ( mpp_pe().NE.mpp_root_pe() ) RETURN - ! Fatal error if range is present and its extent is not 2. - IF ( PRESENT(range) ) THEN - IF ( SIZE(range) .NE. 2 ) THEN - ! extent of range should be 2 - CALL error_mesg ('diag_util_mod::log_diag_field_info', 'extent of range should be 2', FATAL) - END IF - END IF - lmodule = TRIM(module_name) lfield = TRIM(field_name) @@ -678,33 +668,15 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& IF ( use_cmor ) THEN WRITE (lmissval,*) CMOR_MISSING_VALUE ELSE - SELECT TYPE (missing_value) - TYPE IS (real(kind=r4_kind)) - missing_value_use = missing_value - TYPE IS (real(kind=r8_kind)) - missing_value_use = real(missing_value) - CLASS DEFAULT - CALL error_mesg ('diag_util_mod::log_diag_field_info',& - & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - WRITE (lmissval,*) missing_value_use + WRITE (lmissval,*) missing_value END IF ELSE lmissval = '' ENDIF IF ( PRESENT(range) ) THEN - SELECT TYPE (range) - TYPE IS (real(kind=r4_kind)) - range_use = range - TYPE IS (real(kind=r8_kind)) - range_use = real(range) - CLASS DEFAULT - CALL error_mesg ('diag_util_mod::log_diag_field_info',& - & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - WRITE (lmin,*) range_use(1) - WRITE (lmax,*) range_use(2) + WRITE (lmin,*) range(1) + WRITE (lmax,*) range(2) ELSE lmin = '' lmax = '' diff --git a/sat_vapor_pres/sat_vapor_pres.F90 b/sat_vapor_pres/sat_vapor_pres.F90 index 054860e530..c92e134a94 100644 --- a/sat_vapor_pres/sat_vapor_pres.F90 +++ b/sat_vapor_pres/sat_vapor_pres.F90 @@ -194,8 +194,6 @@ module sat_vapor_pres_mod lookup_des3_k, lookup_es3_des3_k, & compute_qs_k, compute_mrs_k - use platform_mod, only: r4_kind, r8_kind - implicit none private @@ -741,8 +739,8 @@ module sat_vapor_pres_mod ! subroutine lookup_es_0d ( temp, esat, err_msg ) - class(*), intent(in) :: temp - class(*), intent(out) :: esat + real, intent(in) :: temp + real, intent(out) :: esat character(len=*), intent(out), optional :: err_msg integer :: nbad @@ -773,8 +771,8 @@ end subroutine lookup_es_0d ! subroutine lookup_es_1d ( temp, esat, err_msg ) - class(*), intent(in) :: temp(:) - class(*), intent(out) :: esat(:) + real, intent(in) :: temp(:) + real, intent(out) :: esat(:) character(len=*), intent(out), optional :: err_msg character(len=54) :: err_msg_local @@ -809,8 +807,8 @@ end subroutine lookup_es_1d ! subroutine lookup_es_2d ( temp, esat, err_msg ) - class(*), intent(in) :: temp(:,:) - class(*), intent(out) :: esat(:,:) + real, intent(in) :: temp(:,:) + real, intent(out) :: esat(:,:) character(len=*), intent(out), optional :: err_msg character(len=54) :: err_msg_local @@ -845,8 +843,8 @@ end subroutine lookup_es_2d ! subroutine lookup_es_3d ( temp, esat, err_msg ) - class(*), intent(in) :: temp(:,:,:) - class(*), intent(out) :: esat(:,:,:) + real, intent(in) :: temp(:,:,:) + real, intent(out) :: esat(:,:,:) character(len=*), intent(out), optional :: err_msg integer :: nbad @@ -1977,10 +1975,10 @@ end subroutine lookup_es3_des3_3d subroutine compute_qs_0d ( temp, press, qsat, q, hc, dqsdT, esat, & err_msg, es_over_liq, es_over_liq_and_ice ) - class(*), intent(in) :: temp, press - class(*), intent(out) :: qsat - class(*), intent(in), optional :: q, hc - class(*), intent(out), optional :: dqsdT, esat + real, intent(in) :: temp, press + real, intent(out) :: qsat + real, intent(in), optional :: q, hc + real, intent(out), optional :: dqsdT, esat character(len=*), intent(out), optional :: err_msg logical,intent(in), optional :: es_over_liq logical,intent(in), optional :: es_over_liq_and_ice @@ -2035,11 +2033,11 @@ end subroutine compute_qs_0d subroutine compute_qs_1d ( temp, press, qsat, q, hc, dqsdT, esat, & err_msg, es_over_liq, es_over_liq_and_ice ) - class(*), intent(in) :: temp(:), press(:) - class(*), intent(out) :: qsat(:) - class(*), intent(in), optional :: q(:) - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT(:), esat(:) + real, intent(in) :: temp(:), press(:) + real, intent(out) :: qsat(:) + real, intent(in), optional :: q(:) +real, intent(in), optional :: hc + real, intent(out), optional :: dqsdT(:), esat(:) character(len=*), intent(out), optional :: err_msg logical,intent(in), optional :: es_over_liq logical,intent(in), optional :: es_over_liq_and_ice @@ -2097,11 +2095,11 @@ end subroutine compute_qs_1d subroutine compute_qs_2d ( temp, press, qsat, q, hc, dqsdT, esat, & err_msg, es_over_liq, es_over_liq_and_ice ) - class(*), intent(in) :: temp(:,:), press(:,:) - class(*), intent(out) :: qsat(:,:) - class(*), intent(in), optional :: q(:,:) - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT(:,:), esat(:,:) + real, intent(in) :: temp(:,:), press(:,:) + real, intent(out) :: qsat(:,:) + real, intent(in), optional :: q(:,:) + real, intent(in), optional :: hc + real, intent(out), optional :: dqsdT(:,:), esat(:,:) character(len=*), intent(out), optional :: err_msg logical,intent(in), optional :: es_over_liq logical,intent(in), optional :: es_over_liq_and_ice @@ -2158,11 +2156,11 @@ end subroutine compute_qs_2d subroutine compute_qs_3d ( temp, press, qsat, q, hc, dqsdT, esat, & err_msg, es_over_liq, es_over_liq_and_ice ) - class(*), intent(in) :: temp(:,:,:), press(:,:,:) - class(*), intent(out) :: qsat(:,:,:) - class(*), intent(in), optional :: q(:,:,:) - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT(:,:,:), esat(:,:,:) + real, intent(in) :: temp(:,:,:), press(:,:,:) + real, intent(out) :: qsat(:,:,:) + real, intent(in), optional :: q(:,:,:) + real, intent(in), optional :: hc + real, intent(out), optional :: dqsdT(:,:,:), esat(:,:,:) character(len=*), intent(out), optional :: err_msg logical,intent(in), optional :: es_over_liq logical,intent(in), optional :: es_over_liq_and_ice @@ -2610,245 +2608,131 @@ end subroutine sat_vapor_pres_init !####################################################################### function check_1d ( temp ) result ( nbad ) - class(*), intent(in) :: temp(:) + real , intent(in) :: temp(:) integer :: nbad, ind, i nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) nbad = nbad+1 - enddo - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) nbad = nbad+1 - enddo - class default - call error_mesg ('sat_vapor_pres_mod::check_1d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + do i = 1, size(temp,1) + ind = int(dtinv*(temp(i)-tmin+teps)) + if (ind < 0 .or. ind > nlim) nbad = nbad+1 + enddo end function check_1d !------------------------------------------------ function check_2d ( temp ) result ( nbad ) - class(*), intent(in) :: temp(:,:) + real , intent(in) :: temp(:,:) integer :: nbad integer :: j - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - nbad = nbad + check_1d ( temp(:,j) ) - enddo - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - nbad = nbad + check_1d ( temp(:,j) ) - enddo - class default - call error_mesg ('sat_vapor_pres_mod::check_2d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + nbad = 0 + do j = 1, size(temp,2) + nbad = nbad + check_1d ( temp(:,j) ) + enddo end function check_2d !####################################################################### subroutine temp_check_1d ( temp ) - class(*), intent(in) :: temp(:) + real , intent(in) :: temp(:) integer :: i, unit unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) - type is (real(kind=r8_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) - class default - call error_mesg ('sat_vapor_pres_mod::temp_check_1d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) end subroutine temp_check_1d !-------------------------------------------------------------- subroutine temp_check_2d ( temp ) - class(*), intent(in) :: temp(:,:) + real , intent(in) :: temp(:,:) integer :: i, j, unit unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) - type is (real(kind=r8_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) - class default - call error_mesg ('sat_vapor_pres_mod::temp_check_2d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) + write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) end subroutine temp_check_2d !-------------------------------------------------------------- subroutine temp_check_3d ( temp ) - class(*), intent(in) :: temp(:,:,:) + real, intent(in) :: temp(:,:,:) integer :: i, j, k, unit unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) - write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) - type is (real(kind=r8_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) - write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) - class default - call error_mesg ('sat_vapor_pres_mod::temp_check_3d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) + write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) + write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) end subroutine temp_check_3d !####################################################################### subroutine show_all_bad_0d ( temp ) - class(*), intent(in) :: temp + real , intent(in) :: temp integer :: ind, unit unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - ind = int(dtinv*(temp-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() - endif - type is (real(kind=r8_kind)) - ind = int(dtinv*(temp-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() - endif - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_0d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + ind = int(dtinv*(temp-tmin+teps)) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() + endif end subroutine show_all_bad_0d !-------------------------------------------------------------- subroutine show_all_bad_1d ( temp ) - class(*), intent(in) :: temp(:) + real , intent(in) :: temp(:) integer :: i, ind, unit unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - do i=1,size(temp) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() - endif - enddo - type is (real(kind=r8_kind)) - do i=1,size(temp) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() - endif - enddo - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_1d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + do i=1,size(temp) + ind = int(dtinv*(temp(i)-tmin+teps)) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() + endif + enddo end subroutine show_all_bad_1d !-------------------------------------------------------------- subroutine show_all_bad_2d ( temp ) - class(*), intent(in) :: temp(:,:) + real , intent(in) :: temp(:,:) integer :: i, j, ind, unit unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() - endif - enddo - enddo - type is (real(kind=r8_kind)) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() - endif - enddo - enddo - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_2d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + do j=1,size(temp,2) + do i=1,size(temp,1) + ind = int(dtinv*(temp(i,j)-tmin+teps)) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() + endif + enddo + enddo end subroutine show_all_bad_2d !-------------------------------------------------------------- subroutine show_all_bad_3d ( temp ) - class(*), intent(in) :: temp(:,:,:) + real, intent(in) :: temp(:,:,:) integer :: i, j, k, ind, unit unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - do k=1,size(temp,3) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j,k)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe() - endif - enddo - enddo - enddo - type is (real(kind=r8_kind)) - do k=1,size(temp,3) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j,k)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe() - endif - enddo - enddo - enddo - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_3d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + do k=1,size(temp,3) + do j=1,size(temp,2) + do i=1,size(temp,1) + ind = int(dtinv*(temp(i,j,k)-tmin+teps)) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe() + endif + enddo + enddo + enddo end subroutine show_all_bad_3d diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90 index 3a1ba4f43b..a9662a7d3b 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -50,9 +50,6 @@ module sat_vapor_pres_k_mod ! not be a fortran module. This complicates things greatly for questionable ! benefit and could be done as a second step anyway, if necessary. - use fms_mod, only: error_mesg, FATAL - use platform_mod, only: r4_kind, r8_kind - implicit none private @@ -478,323 +475,85 @@ end function compute_es_liq_ice_k subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & dqsdT, esat, es_over_liq, es_over_liq_and_ice) - class(*), intent(in), dimension(:,:,:) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out), dimension(:,:,:) :: qs - integer, intent(out) :: nbad - class(*), intent(in), dimension(:,:,:), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), dimension(:,:,:), optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind), allocatable, dimension(:,:,:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments - real(kind=r8_kind), allocatable, dimension(:,:,:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments + real, intent(in), dimension(:,:,:) :: temp, press + real, intent(in) :: eps, zvir + real, intent(out), dimension(:,:,:) :: qs + integer, intent(out) :: nbad + real, intent(in), dimension(:,:,:), optional :: q + real, intent(in), optional :: hc + real, intent(out), dimension(:,:,:), optional :: dqsdT, esat + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + real, dimension(size(temp,1), size(temp,2), size(temp,3)) :: & + esloc, desat, denom integer :: i, j, k real :: hc_loc - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL) - end if if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if - - select type (temp) - type is (real(kind=r4_kind)) - allocate(esloc_r4(size(temp,1), size(temp,2), size(temp,3))) - allocate(desat_r4(size(temp,1), size(temp,2), size(temp,3))) - allocate(denom_r4(size(temp,1), size(temp,2), size(temp,3))) - type is (real(kind=r8_kind)) - allocate(esloc_r8(size(temp,1), size(temp,2), size(temp,3))) - allocate(desat_r8(size(temp,1), size(temp,2), size(temp,3))) - allocate(denom_r8(size(temp,1), size(temp,2), size(temp,3))) - end select - - if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select + hc_loc = hc else hc_loc = 1.0 endif - - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif + if (present(es_over_liq)) then + if (present (dqsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif + call lookup_es2_k (temp, esloc, nbad) endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - + else if (present(es_over_liq_and_ice)) then + if (present (dqsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dqsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select + esat = esloc endif - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - do k=1,size(qs,3) - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r4(i,j,k) > 0.0_r4_kind) then - qs(i,j,k) = real(eps, kind=r4_kind)*esloc_r4(i,j,k)/denom_r4(i,j,k) - else - qs(i,j,k) = real(eps, kind=r4_kind) - endif - end do - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select + if (present (q) .and. use_exact_qs) then + qs = (1.0 + zvir*q)*eps*esloc/press + if (present (dqsdT)) then + dqsdT = (1.0 + zvir*q)*eps*desat/press + endif + else ! (present(q)) + denom = press - (1.0 - eps)*esloc + do k=1,size(qs,3) + do j=1,size(qs,2) + do i=1,size(qs,1) + if (denom(i,j,k) > 0.0) then + qs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k) + else + qs(i,j,k) = eps endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - do k=1,size(qs,3) - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r8(i,j,k) > 0.0) then - qs(i,j,k) = eps*esloc_r8(i,j,k)/denom_r8(i,j,k) - else - qs(i,j,k) = eps - endif - end do - end do end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select + end do + end do + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select + qs = -999. if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select + dqsdT = -999. endif if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select + esat = -999. endif endif ! (nbad = 0) - select type (temp) - type is (real(kind=r4_kind)) - deallocate(esloc_r4, desat_r4, denom_r4) - type is (real(kind=r8_kind)) - deallocate(esloc_r8, desat_r8, denom_r8) - end select end subroutine compute_qs_k_3d @@ -803,319 +562,83 @@ end subroutine compute_qs_k_3d subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & dqsdT, esat, es_over_liq, es_over_liq_and_ice) - class(*), intent(in), dimension(:,:) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out), dimension(:,:) :: qs - integer, intent(out) :: nbad - class(*), intent(in), dimension(:,:), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), dimension(:,:), optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind), allocatable, dimension(:,:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments - real(kind=r8_kind), allocatable, dimension(:,:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments + real, intent(in), dimension(:,:) :: temp, press + real, intent(in) :: eps, zvir + real, intent(out), dimension(:,:) :: qs + integer, intent(out) :: nbad + real, intent(in), dimension(:,:), optional :: q + real, intent(in), optional :: hc + real, intent(out), dimension(:,:), optional :: dqsdT, esat + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + real, dimension(size(temp,1), size(temp,2)) :: esloc, desat, denom integer :: i, j real :: hc_loc - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL) - end if - - if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if - - select type (temp) - type is (real(kind=r4_kind)) - allocate(esloc_r4(size(temp,1), size(temp,2))) - allocate(desat_r4(size(temp,1), size(temp,2))) - allocate(denom_r4(size(temp,1), size(temp,2))) - type is (real(kind=r8_kind)) - allocate(esloc_r8(size(temp,1), size(temp,2))) - allocate(desat_r8(size(temp,1), size(temp,2))) - allocate(denom_r8(size(temp,1), size(temp,2))) - end select if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select + hc_loc = hc else hc_loc = 1.0 endif - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif + if (present(es_over_liq)) then + if (present (dqsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif + call lookup_es2_k (temp, esloc, nbad) endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - + else if (present(es_over_liq_and_ice)) then + if (present (dqsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dqsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select + esat = esloc endif - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r4(i,j) > 0.0_r4_kind) then - qs(i,j) = real(eps, kind=r4_kind)*esloc_r4(i,j)/denom_r4(i,j) - else - qs(i,j) = real(eps, kind=r4_kind) - endif - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r8(i,j) > 0.0) then - qs(i,j) = eps*esloc_r8(i,j)/denom_r8(i,j) - else - qs(i,j) = eps - endif - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select + if (present (q) .and. use_exact_qs) then + qs = (1.0 + zvir*q)*eps*esloc/press + if (present (dqsdT)) then + dqsdT = (1.0 + zvir*q)*eps*desat/press + endif + else ! (present(q)) + denom = press - (1.0 - eps)*esloc + do j=1,size(qs,2) + do i=1,size(qs,1) + if (denom(i,j) > 0.0) then + qs(i,j) = eps*esloc(i,j)/denom(i,j) + else + qs(i,j) = eps + endif + end do + end do + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select + qs = -999. if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select + dqsdT = -999. endif if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select + esat = -999. endif endif ! (nbad = 0) - select type (temp) - type is (real(kind=r4_kind)) - deallocate(esloc_r4, desat_r4, denom_r4) - type is (real(kind=r8_kind)) - deallocate(esloc_r8, desat_r8, denom_r8) - end select end subroutine compute_qs_k_2d @@ -1124,315 +647,81 @@ end subroutine compute_qs_k_2d subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & dqsdT, esat, es_over_liq, es_over_liq_and_ice) - class(*), intent(in), dimension(:) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out),dimension(:) :: qs - integer, intent(out) :: nbad - class(*), intent(in), dimension(:), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), dimension(:),optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind), allocatable, dimension(:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments - real(kind=r8_kind), allocatable, dimension(:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments + real, intent(in), dimension(:) :: temp, press + real, intent(in) :: eps, zvir + real, intent(out), dimension(:) :: qs + integer, intent(out) :: nbad + real, intent(in), dimension(:), optional :: q + real, intent(in), optional :: hc + real, intent(out), dimension(:), optional :: dqsdT, esat + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + real, dimension(size(temp,1)) :: esloc, desat, denom integer :: i real :: hc_loc - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL) - end if - - if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if - - select type (temp) - type is (real(kind=r4_kind)) - allocate(esloc_r4(size(temp,1))) - allocate(desat_r4(size(temp,1))) - allocate(denom_r4(size(temp,1))) - type is (real(kind=r8_kind)) - allocate(esloc_r8(size(temp,1))) - allocate(desat_r8(size(temp,1))) - allocate(denom_r8(size(temp,1))) - end select if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select + hc_loc = hc else hc_loc = 1.0 endif - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif + if (present(es_over_liq)) then + if (present (dqsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif + call lookup_es2_k (temp, esloc, nbad) endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - + else if (present(es_over_liq_and_ice)) then + if (present (dqsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dqsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select + esat = esloc endif - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - do i=1,size(qs,1) - if (denom_r4(i) > 0.0_r4_kind) then - qs(i) = real(eps, kind=r4_kind)*esloc_r4(i)/denom_r4(i) - else - qs(i) = real(eps, kind=r4_kind) - endif - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - do i=1,size(qs,1) - if (denom_r8(i) > 0.0) then - qs(i) = eps*esloc_r8(i)/denom_r8(i) - else - qs(i) = eps - endif - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select + if (present (q) .and. use_exact_qs) then + qs = (1.0 + zvir*q)*eps*esloc/press + if (present (dqsdT)) then + dqsdT = (1.0 + zvir*q)*eps*desat/press + endif + else ! (present(q)) + denom = press - (1.0 - eps)*esloc + do i=1,size(qs,1) + if (denom(i) > 0.0) then + qs(i) = eps*esloc(i)/denom(i) + else + qs(i) = eps + endif + end do + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select + qs = -999. if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select + dqsdT = -999. endif if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select + esat = -999. endif endif ! (nbad = 0) - select type (temp) - type is (real(kind=r4_kind)) - deallocate(esloc_r4, desat_r4, denom_r4) - type is (real(kind=r8_kind)) - deallocate(esloc_r8, desat_r8, denom_r8) - end select end subroutine compute_qs_k_1d @@ -1441,293 +730,79 @@ end subroutine compute_qs_k_1d subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & dqsdT, esat, es_over_liq, es_over_liq_and_ice) - class(*), intent(in) :: temp, press + real, intent(in) :: temp, press real, intent(in) :: eps, zvir - class(*), intent(out) :: qs + real, intent(out) :: qs integer, intent(out) :: nbad - class(*), intent(in), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT, esat + real, intent(in), optional :: q + real, intent(in), optional :: hc + real, intent(out), optional :: dqsdT, esat logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice + logical,intent(in), optional :: es_over_liq_and_ice - real(kind=r4_kind) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments - real(kind=r8_kind) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments + real :: esloc, desat, denom real :: hc_loc - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL) - end if if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if - - if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select + hc_loc = hc else hc_loc = 1.0 endif - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif + if (present(es_over_liq)) then + if (present (dqsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif + call lookup_es2_k (temp, esloc, nbad) endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - + else if (present(es_over_liq_and_ice)) then + if (present (dqsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dqsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select + esat = esloc endif - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - if (denom_r4 > 0.0_r4_kind) then - qs = real(eps, kind=r4_kind)*esloc_r4/denom_r4 - else - qs = real(eps, kind=r4_kind) - endif - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - if (denom_r8 > 0.0) then - qs = eps*esloc_r8/denom_r8 - else - qs = eps - endif - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select + if (present (q) .and. use_exact_qs) then + qs = (1.0 + zvir*q)*eps*esloc/press + if (present (dqsdT)) then + dqsdT = (1.0 + zvir*q)*eps*desat/press + endif + else ! (present(q)) + denom = press - (1.0 - eps)*esloc + if (denom > 0.0) then + qs = eps*esloc/denom + else + qs = eps + endif + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select + qs = -999. if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select + dqsdT = -999. endif if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select + esat = -999. endif endif ! (nbad = 0) + end subroutine compute_qs_k_0d !####################################################################### @@ -2073,292 +1148,107 @@ end subroutine compute_mrs_k_0d !####################################################################### subroutine lookup_es_des_k_3d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat, desat + real, intent(in), dimension(:,:,:) :: temp + real, intent(out), dimension(:,:,:) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - desat(i,j,k) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - enddo - end select - end select - end select + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j,k) = TABLE(ind+1) + & + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) + desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + endif + enddo + enddo + enddo end subroutine lookup_es_des_k_3d !####################################################################### subroutine lookup_es_des_k_2d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat, desat + real, intent(in), dimension(:,:) :: temp + real, intent(out), dimension(:,:) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - desat(i,j) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - end select - end select - end select + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j) = TABLE(ind+1) + & + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) + desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + endif + enddo + enddo end subroutine lookup_es_des_k_2d !####################################################################### subroutine lookup_es_des_k_1d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat, desat + real, intent(in), dimension(:) :: temp + real, intent(out), dimension(:) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - desat(i) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - end select - end select - end select + do i = 1, size(temp,1) + tmp = temp(i)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i) = TABLE(ind+1) + & + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) + desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + endif + enddo end subroutine lookup_es_des_k_1d !####################################################################### subroutine lookup_es_des_k_0d (temp, esat, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat, desat + real, intent(in) :: temp + real, intent(out) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + tmp = temp-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 else del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + esat = TABLE(ind+1) + & + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) + desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) endif end subroutine lookup_es_des_k_0d @@ -2366,754 +1256,289 @@ end subroutine lookup_es_des_k_0d !####################################################################### subroutine lookup_es_k_3d(temp, esat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat + real, intent(in), dimension(:,:,:) :: temp + real, intent(out), dimension(:,:,:) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - endif - enddo - enddo - enddo - end select - end select + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j,k) = TABLE(ind+1) + & + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) + endif + enddo + enddo + enddo end subroutine lookup_es_k_3d !####################################################################### subroutine lookup_des_k_3d(temp, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: desat + real, intent(in), dimension(:,:,:) :: temp + real, intent(out), dimension(:,:,:) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - enddo - end select - end select + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + endif + enddo + enddo + enddo end subroutine lookup_des_k_3d !####################################################################### subroutine lookup_des_k_2d(temp, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: desat + real, intent(in), dimension(:,:) :: temp + real, intent(out), dimension(:,:) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - end select - end select + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + endif + enddo + enddo end subroutine lookup_des_k_2d !####################################################################### subroutine lookup_es_k_2d(temp, esat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat + real, intent(in), dimension(:,:) :: temp + real, intent(out), dimension(:,:) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - endif - enddo - enddo - end select - end select + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j) = TABLE(ind+1) + del*(DTABLE(ind+1) + & + del*D2TABLE(ind+1)) + endif + enddo + enddo end subroutine lookup_es_k_2d !####################################################################### subroutine lookup_des_k_1d(temp, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: desat + real, intent(in), dimension(:) :: temp + real, intent(out), dimension(:) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - end select - end select + do i = 1, size(temp,1) + tmp = temp(i)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + endif + enddo end subroutine lookup_des_k_1d !####################################################################### subroutine lookup_es_k_1d(temp, esat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat + real, intent(in), dimension(:) :: temp + real, intent(out), dimension(:) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) - endif - enddo - end select - end select + do i = 1, size(temp,1) + tmp = temp(i)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) + endif + enddo end subroutine lookup_es_k_1d !####################################################################### subroutine lookup_des_k_0d(temp, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: desat + real, intent(in) :: temp + real, intent(out) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + tmp = temp-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 else del = tmp-dtres*real(ind) - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) endif end subroutine lookup_des_k_0d !####################################################################### subroutine lookup_es_k_0d(temp, esat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat + real, intent(in) :: temp + real, intent(out) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + tmp = temp-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 else del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) endif end subroutine lookup_es_k_0d !####################################################################### subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat, desat + real, intent(in), dimension(:,:,:) :: temp + real, intent(out), dimension(:,:,:) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - desat(i,j,k) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - enddo - end select - end select - end select + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j,k) = TABLE2(ind+1) + & + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) + desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + endif + enddo + enddo + enddo end subroutine lookup_es2_des2_k_3d !####################################################################### subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat, desat + real, intent(in), dimension(:,:) :: temp + real, intent(out), dimension(:,:) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - desat(i,j) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - end select - end select - end select + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j) = TABLE2(ind+1) + & + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) + desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + endif + enddo + enddo end subroutine lookup_es2_des2_k_2d !####################################################################### subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat, desat + real, intent(in), dimension(:) :: temp + real, intent(out), dimension(:) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - desat(i) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - end select - end select - end select + do i = 1, size(temp,1) + tmp = temp(i)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i) = TABLE2(ind+1) + & + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) + desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + endif + enddo end subroutine lookup_es2_des2_k_1d !####################################################################### subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat, desat + real, intent(in) :: temp + real, intent(out) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + tmp = temp-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 else del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + esat = TABLE2(ind+1) + & + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) + desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) endif end subroutine lookup_es2_des2_k_0d @@ -3121,462 +1546,182 @@ end subroutine lookup_es2_des2_k_0d !####################################################################### subroutine lookup_es2_k_3d(temp, esat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat + real, intent(in), dimension(:,:,:) :: temp + real, intent(out), dimension(:,:,:) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - endif - enddo - enddo - enddo - end select - end select + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j,k) = TABLE2(ind+1) + & + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) + endif + enddo + enddo + enddo end subroutine lookup_es2_k_3d !####################################################################### subroutine lookup_des2_k_3d(temp, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: desat + real, intent(in), dimension(:,:,:) :: temp + real, intent(out), dimension(:,:,:) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - enddo - end select - end select + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + endif + enddo + enddo + enddo end subroutine lookup_des2_k_3d !####################################################################### subroutine lookup_des2_k_2d(temp, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: desat + real, intent(in), dimension(:,:) :: temp + real, intent(out), dimension(:,:) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - end select - end select + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + endif + enddo + enddo end subroutine lookup_des2_k_2d !####################################################################### subroutine lookup_es2_k_2d(temp, esat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat + real, intent(in), dimension(:,:) :: temp + real, intent(out), dimension(:,:) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - endif - enddo - enddo - end select - end select + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j) = TABLE2(ind+1) + del*(DTABLE2(ind+1) + & + del*D2TABLE2(ind+1)) + endif + enddo + enddo end subroutine lookup_es2_k_2d !####################################################################### subroutine lookup_des2_k_1d(temp, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: desat + real, intent(in), dimension(:) :: temp + real, intent(out), dimension(:) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - end select - end select + do i = 1, size(temp,1) + tmp = temp(i)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + endif + enddo end subroutine lookup_des2_k_1d !####################################################################### subroutine lookup_es2_k_1d(temp, esat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat + real, intent(in), dimension(:) :: temp + real, intent(out), dimension(:) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) + endif + enddo - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) - endif - enddo - end select - end select - end subroutine lookup_es2_k_1d !####################################################################### subroutine lookup_des2_k_0d(temp, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: desat + real, intent(in) :: temp + real, intent(out) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + tmp = temp-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 else del = tmp-dtres*real(ind) - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) endif end subroutine lookup_des2_k_0d !####################################################################### subroutine lookup_es2_k_0d(temp, esat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat + real, intent(in) :: temp + real, intent(out) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + tmp = temp-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 else del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) endif end subroutine lookup_es2_k_0d @@ -3585,292 +1730,107 @@ end subroutine lookup_es2_k_0d !####################################################################### subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat, desat + real, intent(in), dimension(:,:,:) :: temp + real, intent(out), dimension(:,:,:) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - desat(i,j,k) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - enddo - end select - end select - end select + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j,k) = TABLE3(ind+1) + & + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) + desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + endif + enddo + enddo + enddo end subroutine lookup_es3_des3_k_3d !####################################################################### subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat, desat + real, intent(in), dimension(:,:) :: temp + real, intent(out), dimension(:,:) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - desat(i,j) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - end select - end select - end select + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j) = TABLE3(ind+1) + & + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) + desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + endif + enddo + enddo end subroutine lookup_es3_des3_k_2d !####################################################################### subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat, desat + real, intent(in), dimension(:) :: temp + real, intent(out), dimension(:) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - desat(i) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - end select - end select - end select + do i = 1, size(temp,1) + tmp = temp(i)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i) = TABLE3(ind+1) + & + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) + desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + endif + enddo end subroutine lookup_es3_des3_k_1d !####################################################################### subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat, desat + real, intent(in) :: temp + real, intent(out) :: esat, desat integer, intent(out) :: nbad real :: tmp, del integer :: ind nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + tmp = temp-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 else del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + esat = TABLE3(ind+1) + & + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) + desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) endif end subroutine lookup_es3_des3_k_0d @@ -3878,462 +1838,182 @@ end subroutine lookup_es3_des3_k_0d !####################################################################### subroutine lookup_es3_k_3d(temp, esat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat + real, intent(in), dimension(:,:,:) :: temp + real, intent(out), dimension(:,:,:) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - endif - enddo - enddo - enddo - end select - end select + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j,k) = TABLE3(ind+1) + & + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) + endif + enddo + enddo + enddo end subroutine lookup_es3_k_3d !####################################################################### subroutine lookup_des3_k_3d(temp, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: desat + real, intent(in), dimension(:,:,:) :: temp + real, intent(out), dimension(:,:,:) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - enddo - end select - end select + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + endif + enddo + enddo + enddo end subroutine lookup_des3_k_3d !####################################################################### subroutine lookup_des3_k_2d(temp, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: desat + real, intent(in), dimension(:,:) :: temp + real, intent(out), dimension(:,:) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - end select - end select + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + endif + enddo + enddo end subroutine lookup_des3_k_2d !####################################################################### subroutine lookup_es3_k_2d(temp, esat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat + real, intent(in), dimension(:,:) :: temp + real, intent(out), dimension(:,:) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - endif - enddo - enddo - end select - end select + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i,j) = TABLE3(ind+1) + del*(DTABLE3(ind+1) + & + del*D2TABLE3(ind+1)) + endif + enddo + enddo end subroutine lookup_es3_k_2d !####################################################################### subroutine lookup_des3_k_1d(temp, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: desat + real, intent(in), dimension(:) :: temp + real, intent(out), dimension(:) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - end select - end select + do i = 1, size(temp,1) + tmp = temp(i)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + endif + enddo end subroutine lookup_des3_k_1d !####################################################################### subroutine lookup_es3_k_1d(temp, esat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat + real, intent(in), dimension(:) :: temp + real, intent(out), dimension(:) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) - end if nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) - endif - enddo - end select - end select + do i = 1, size(temp,1) + tmp = temp(i)-tminl + ind = int(dtinvl*(tmp+tepsl)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtres*real(ind) + esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) + endif + enddo end subroutine lookup_es3_k_1d !####################################################################### subroutine lookup_des3_k_0d(temp, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: desat + real, intent(in) :: temp + real, intent(out) :: desat integer, intent(out) :: nbad real :: tmp, del integer :: ind nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + tmp = temp-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 else del = tmp-dtres*real(ind) - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) endif end subroutine lookup_des3_k_0d !####################################################################### subroutine lookup_es3_k_0d(temp, esat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat + real, intent(in) :: temp + real, intent(out) :: esat integer, intent(out) :: nbad real :: tmp, del integer :: ind nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + tmp = temp-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 else del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select + esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) endif end subroutine lookup_es3_k_0d diff --git a/time_manager/time_manager.F90 b/time_manager/time_manager.F90 index 02eee5721c..b77355ced1 100644 --- a/time_manager/time_manager.F90 +++ b/time_manager/time_manager.F90 @@ -87,7 +87,7 @@ module time_manager_mod -use platform_mod, only: r4_kind, r8_kind +use platform_mod, only: r8_kind use constants_mod, only: rseconds_per_day=>seconds_per_day use fms_mod, only: error_mesg, FATAL, WARNING, write_version_number, stdout @@ -1202,7 +1202,7 @@ end function time_type_to_real !! @return A filled time type variable, and an error message if an !! error occurs. function real_to_time_type(x,err_msg) result(t) - class(*),intent(in) :: x !< Number of seconds. + real,intent(in) :: x !< Number of seconds. character(len=*),intent(out),optional :: err_msg !< Error message. type(time_type) :: t integer :: days @@ -1213,29 +1213,9 @@ function real_to_time_type(x,err_msg) result(t) real :: tps real :: a tps = real(ticks_per_second) - - select type (x) - type is (real(kind=r4_kind)) - a = x/spd - type is (real(kind=r8_kind)) - a = real(x)/spd - class default - call error_mesg('time_manager_mod::real_to_time_type',& - & 'x is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + a = x/spd days = safe_rtoi(a,do_floor) - - select type (x) - type is (real(kind=r4_kind)) - a = x - real(days)*spd - type is (real(kind=r8_kind)) - a = real(x) - real(days)*spd - class default - call error_mesg('time_manager_mod::real_to_time_type',& - & 'x is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - + a = x - real(days)*spd seconds = safe_rtoi(a,do_floor) a = (a - real(seconds))*tps ticks = safe_rtoi(a,do_nearest) diff --git a/tracer_manager/tracer_manager.F90 b/tracer_manager/tracer_manager.F90 index 348b704a81..79ea8ac623 100644 --- a/tracer_manager/tracer_manager.F90 +++ b/tracer_manager/tracer_manager.F90 @@ -76,8 +76,6 @@ module tracer_manager_mod fm_exists, & MODEL_NAMES -use platform_mod, only: r4_kind, r8_kind - implicit none private @@ -1039,7 +1037,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg) integer, intent(in) :: model !< Parameter representing component model in use integer, intent(in) :: n !< Tracer number -class(*), intent(inout), dimension(:,:,:) :: tracer !< Initialized tracer array +real, intent(inout), dimension(:,:,:) :: tracer !< Initialized tracer array character(len=*), intent(out), optional :: err_msg real :: surf_value, multiplier @@ -1065,14 +1063,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg) bottom_value = surf_value multiplier = 1.0 -select type (tracer) -type is (real(kind=r4_kind)) - tracer = surf_value -type is (real(kind=r8_kind)) - tracer = surf_value -class default - call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)") -end select +tracer = surf_value if ( query_method ( 'profile_type',model,n,scheme,control)) then !Change the tracer_number to the tracer_manager version @@ -1081,14 +1072,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg) profile_type = 'Fixed' flag =parse(control,'surface_value',surf_value) multiplier = 1.0 - select type (tracer) - type is (real(kind=r4_kind)) - tracer = surf_value - type is (real(kind=r8_kind)) - tracer = surf_value - class default - call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)") - end select + tracer = surf_value endif if(lowercase(trim(scheme(1:7))).eq.'profile') then @@ -1121,36 +1105,16 @@ subroutine set_tracer_profile(model, n, tracer, err_msg) select case (tracers(n1)%model) case (MODEL_ATMOS) multiplier = exp( log (top_value/surf_value) /numlevels) - select type (tracer) - type is (real(kind=r4_kind)) - tracer(:,:,1) = surf_value - do k = 2, size(tracer,3) - tracer(:,:,k) = tracer(:,:,k-1) * multiplier - enddo - type is (real(kind=r8_kind)) - tracer(:,:,1) = surf_value - do k = 2, size(tracer,3) - tracer(:,:,k) = tracer(:,:,k-1) * multiplier - enddo - class default - call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)") - end select + tracer(:,:,1) = surf_value + do k = 2, size(tracer,3) + tracer(:,:,k) = tracer(:,:,k-1) * multiplier + enddo case (MODEL_OCEAN) multiplier = exp( log (bottom_value/surf_value) /numlevels) - select type (tracer) - type is (real(kind=r4_kind)) - tracer(:,:,size(tracer,3)) = surf_value - do k = size(tracer,3) - 1, 1, -1 - tracer(:,:,k) = tracer(:,:,k+1) * multiplier - enddo - type is (real(kind=r8_kind)) - tracer(:,:,size(tracer,3)) = surf_value - do k = size(tracer,3) - 1, 1, -1 - tracer(:,:,k) = tracer(:,:,k+1) * multiplier - enddo - class default - call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)") - end select + tracer(:,:,size(tracer,3)) = surf_value + do k = size(tracer,3) - 1, 1, -1 + tracer(:,:,k) = tracer(:,:,k+1) * multiplier + enddo case default end select endif !scheme.eq.profile