I’m getting an error when I try to compile the Community Earth System Model (CESM). It is a large code and contains the following module which computes saturation vapor pressure of water. The module name is shr_wv_sat_mod.F90 and it contains:
module shr_wv_sat_mod
! This portable module contains all CAM methods for estimating the saturation
! vapor pressure of water.
!
! wv_saturation provides CAM-specific interfaces and utilities based on these
! formulae.
!
! Typical usage of this module:
!
! Init:
! call shr_wv_sat_init(, errstring)
!
! Get scheme index from a name string:
! scheme_idx = shr_wv_sat_get_scheme_idx(“GoffGratch”)
! if (.not. shr_wv_sat_valid_idx(scheme_idx))
!
! Get pressures:
! es = shr_wv_sat_svp_liquid(t, scheme_idx)
! es = shr_wv_sat_svp_ice(t, scheme_idx)
!
! Use ice/water transition range:
! es = shr_wv_sat_svp_mixed(t, scheme_idx)
!
! Note that elemental functions cannot be pointed to, nor passed as
! arguments. If you need to do either, it is recommended to wrap the function so
! that it can be given an explicit (non-elemental) interface.
!
! Since usually only one scheme is used at a time, the scheme index is an
! optional argument. If omitted a default scheme will be used, which is
! initially the Goff & Gratch scheme. To change the default, you can make a call
! like this:
!
! call shr_wv_sat_set_default(“MurphyKoop”)
!
! This module has the ability to store lookup tables to cache values. To do so,
! create a ShrWVSatTableSpec instance for water and ice with the desired size
! and range, then call shr_wv_sat_make_tables like so:
!
! type(ShrWVSatTableSpec) :: liquid_spec, ice_spec, mixed_spec
!
! liquid_spec = ShrWVSatTableSpec(151, tmelt-50._rk, 1._rk)
! ice_spec = ShrWVSatTableSpec(106, tmelt-100._rk, 1._rk)
! mixed_spec = ShrWVSatTableSpec(21, tmelt-20._rk, 1._rk)
! call shr_wv_sat_make_tables(liquid_spec, ice_spec, mixed_spec)
!
! Currently, this module only supports making tables for the default scheme, and
! shr_wv_sat_make_tables must be invoked again to produce new tables if the default
! is changed.
!
! Once tables are produced, all uses of the default scheme will attempt to
! linearly interpolate values from the lookup tables. If a temperature is
! outside the table bounds, the original scheme will be invoked as if no table
! was present. That is, the tables will not be extrapolated.
!
! Threading note: The physical constants, the current default, and the lookup
! tables are stored in global, thread-shared variables. Therefore the following
! procedures are not thread-safe:
!
! - shr_wv_sat_init
! - shr_wv_sat_final
! - shr_wv_sat_set_default
! - shr_wv_sat_make_tables
!
! If a multi-threaded application calls any of these procedures, the user is
! responsible for ensuring that each call is perfomed by only one thread, and
! that synchronization is performed to before and after each of these calls.
!
! All other public routines are thread-safe.
#ifdef SHR_WV_SAT_USE_CLUBB_KIND
! If running within CLUBB, use the same precision as CLUBB.
use clubb_precision, only: core_rkind
#endif
implicit none
private
save
! Initialize/finalize module and pick schemes
public shr_wv_sat_init
public shr_wv_sat_final
public shr_wv_sat_get_scheme_idx
public shr_wv_sat_valid_idx
public shr_wv_sat_set_default
! Manage lookup tables
public ShrWVSatTableSpec
public shr_wv_sat_make_tables
! Basic SVP calculations
public shr_wv_sat_svp_liquid
public shr_wv_sat_svp_ice
public shr_wv_sat_svp_mixed
! pressure → humidity conversion
public shr_wv_sat_svp_to_qsat
! pressure → mass mixing ratio conversion
public shr_wv_sat_svp_to_qmmr
! Combined qsat operations
public shr_wv_sat_qsat_liquid
public shr_wv_sat_qsat_ice
public shr_wv_sat_qsat_mixed
#ifdef SHR_WV_SAT_USE_CLUBB_KIND
integer, parameter :: rk = core_rkind
#else
! Double precision
integer, parameter :: rk = selected_real_kind(12)
#endif
real(rk) :: tmelt ! Melting point of water at 1 atm (K)
real(rk) :: h2otrip ! Triple point temperature of water (K)
real(rk) :: ttrice ! Ice-water transition range
real(rk) :: epsilo ! Ice-water transition range
real(rk) :: omeps ! 1._rk - epsilo
! Indices representing individual schemes
integer, parameter :: Invalid_idx = -1
! Skip 0; this was the old implementation of Goff & Gratch.
integer, parameter :: GoffGratch_idx = 1
integer, parameter :: MurphyKoop_idx = 2
integer, parameter :: Bolton_idx = 3
integer, parameter :: Flatau_idx = 4
! Index representing the current default scheme.
integer, parameter :: initial_default_idx = GoffGratch_idx
integer :: default_idx = initial_default_idx
! Type to represent a table specification.
type ShrWVSatTableSpec
integer :: table_size
real(rk) :: minimum
real(rk) :: spacing
end type ShrWVSatTableSpec
type(ShrWVSatTableSpec) :: liquid_table_spec
real(rk), allocatable :: liquid_table(:)
type(ShrWVSatTableSpec) :: ice_table_spec
real(rk), allocatable :: ice_table(:)
type(ShrWVSatTableSpec) :: mixed_table_spec
real(rk), allocatable :: mixed_table(:)
interface shr_wv_sat_svp_liquid
module procedure shr_wv_sat_svp_liquid
module procedure shr_wv_sat_svp_liquid_vec
end interface shr_wv_sat_svp_liquid
interface shr_wv_sat_svp_ice
module procedure shr_wv_sat_svp_ice
module procedure shr_wv_sat_svp_ice_vec
end interface shr_wv_sat_svp_ice
interface shr_wv_sat_svp_mixed
module procedure shr_wv_sat_svp_mixed
module procedure shr_wv_sat_svp_mixed_vec
end interface shr_wv_sat_svp_mixed
interface shr_wv_sat_svp_to_qsat
module procedure shr_wv_sat_svp_to_qsat
module procedure shr_wv_sat_svp_to_qsat_vec
end interface shr_wv_sat_svp_to_qsat
interface shr_wv_sat_svp_to_qmmr
module procedure shr_wv_sat_svp_to_qmmr
module procedure shr_wv_sat_svp_to_qmmr_vec
end interface shr_wv_sat_svp_to_qmmr
interface shr_wv_sat_qsat_liquid
module procedure shr_wv_sat_qsat_liquid
module procedure shr_wv_sat_qsat_liquid_vec
end interface shr_wv_sat_qsat_liquid
interface shr_wv_sat_qsat_ice
module procedure shr_wv_sat_qsat_ice
module procedure shr_wv_sat_qsat_ice_vec
end interface shr_wv_sat_qsat_ice
interface shr_wv_sat_qsat_mixed
module procedure shr_wv_sat_qsat_mixed
module procedure shr_wv_sat_qsat_mixed_vec
end interface shr_wv_sat_qsat_mixed
contains
!---------------------------------------------------------------------
! ADMINISTRATIVE FUNCTIONS
!---------------------------------------------------------------------
! Get physical constants
subroutine shr_wv_sat_init(tmelt_in, h2otrip_in, ttrice_in, epsilo_in, &
errstring)
real(rk), intent(in) :: tmelt_in
real(rk), intent(in) :: h2otrip_in
real(rk), intent(in) :: ttrice_in
real(rk), intent(in) :: epsilo_in
character(len=*), intent(out) :: errstring
errstring = ’ ’
if (ttrice_in < 0._rk) then
write(errstring,*) ‘shr_wv_sat_init: ERROR: ‘, &
ttrice_in,’ was input for ttrice, but negative range is invalid.’
return
end if
tmelt = tmelt_in
h2otrip = h2otrip_in
ttrice = ttrice_in
epsilo = epsilo_in
omeps = 1._rk - epsilo
end subroutine shr_wv_sat_init
! Reset module data to the original state (primarily for testing purposes).
! It doesn’t seem worthwhile to reset the constants, so just deal with options
! and dynamic memory here.
subroutine shr_wv_sat_final()
default_idx = initial_default_idx
if (allocated(liquid_table)) deallocate(liquid_table)
if (allocated(ice_table)) deallocate(ice_table)
if (allocated(mixed_table)) deallocate(mixed_table)
end subroutine shr_wv_sat_final
! Look up index by name.
pure function shr_wv_sat_get_scheme_idx(name) result(idx)
character(len=*), intent(in) :: name
integer :: idx
! Several names are given to most methods in order to support the names that
! CLUBB accepts.
select case (name)
case(“GoffGratch”, “gfdl”, “GFDL”)
idx = GoffGratch_idx
case(“MurphyKoop”)
idx = MurphyKoop_idx
case(“Bolton”, “bolton”)
idx = Bolton_idx
case(“Flatau”, “flatau”)
idx = Flatau_idx
case default
idx = Invalid_idx
end select
end function shr_wv_sat_get_scheme_idx
! Check validity of an index from the above routine.
pure function shr_wv_sat_valid_idx(idx) result(status)
integer, intent(in) :: idx
logical :: status
status = (idx /= Invalid_idx)
end function shr_wv_sat_valid_idx
! Set default scheme (otherwise, Goff & Gratch is default)
! Returns a logical representing success (.true.) or
! failure (.false.).
function shr_wv_sat_set_default(name) result(status)
character(len=*), intent(in) :: name
logical :: status
! Don’t want to overwrite valid default with invalid,
! so assign to temporary and check it first.
integer :: tmp_idx
tmp_idx = shr_wv_sat_get_scheme_idx(name)
status = shr_wv_sat_valid_idx(tmp_idx)
! If we have changed the default, deallocated the tables as well as setting
! the new default.
if (status .and. tmp_idx /= default_idx) then
if (allocated(liquid_table)) deallocate(liquid_table)
if (allocated(ice_table)) deallocate(ice_table)
if (allocated(mixed_table)) deallocate(mixed_table)
default_idx = tmp_idx
end if
end function shr_wv_sat_set_default
subroutine shr_wv_sat_make_tables(liquid_spec_in, ice_spec_in, mixed_spec_in)
type(ShrWVSatTableSpec), intent(in), optional :: liquid_spec_in
type(ShrWVSatTableSpec), intent(in), optional :: ice_spec_in
type(ShrWVSatTableSpec), intent(in), optional :: mixed_spec_in
if (present(liquid_spec_in)) then
liquid_table_spec = liquid_spec_in
call shr_wv_sat_make_one_table(liquid_table_spec, shr_wv_sat_svp_liquid_no_table, &
liquid_table)
end if
if (present(ice_spec_in)) then
ice_table_spec = ice_spec_in
call shr_wv_sat_make_one_table(ice_table_spec, shr_wv_sat_svp_ice_no_table, &
ice_table)
end if
if (present(mixed_spec_in)) then
mixed_table_spec = mixed_spec_in
call shr_wv_sat_make_one_table(mixed_table_spec, shr_wv_sat_svp_mixed_no_table, &
mixed_table)
end if
end subroutine shr_wv_sat_make_tables
! Table-generating generic function (would be simpler with an object-oriented
! design, but we want this code to be runnable on compilers with poor Fortran
! 2003 support). This means we can’t attach function pointers or methods to
! derived types.
subroutine shr_wv_sat_make_one_table(table_spec, svp_function, table)
type(ShrWVSatTableSpec), intent(in) :: table_spec
interface
function svp_function(t, idx) result(es)
import :: rk
real(rk), intent(in) :: t
integer, intent(in) :: idx
real(rk) :: es
end function svp_function
end interface
real(rk), intent(out), allocatable :: table(:)
integer :: i
allocate(table(table_spec%table_size))
do i = 1, table_spec%table_size
table(i) = svp_function( &
table_spec%minimum + table_spec%spacing*real(i-1, rk), &
default_idx)
end do
end subroutine shr_wv_sat_make_one_table
!---------------------------------------------------------------------
! UTILITIES
!---------------------------------------------------------------------
! Get saturation specific humidity given pressure and SVP.
! Specific humidity is limited to the range 0-1.
elemental function shr_wv_sat_svp_to_qsat(es, p) result(qs)
real(rk), intent(in) :: es ! SVP
real(rk), intent(in) :: p ! Current pressure.
real(rk) :: qs
! If pressure is less than SVP, set qs to maximum of 1.
if ( (p - es) <= 0._rk ) then
qs = 1.0_rk
else
qs = epsiloes / (p - omepses)
end if
end function shr_wv_sat_svp_to_qsat
pure function shr_wv_sat_svp_to_qsat_vec(n, es, p) result(qs)
integer, intent(in) :: n ! Size of input arrays
real(rk), intent(in) :: es(n) ! SVP
real(rk), intent(in) :: p(n) ! Current pressure
real(rk) :: qs(n)
integer :: i
! If pressure is less than SVP, set qs to maximum of 1.
do i = 1, n
if ( (p(i) - es(i)) <= 0._rk ) then
qs(i) = 1.0_rk
else
qs(i) = epsiloes(i) / (p(i) - omepses(i))
end if
end do
end function shr_wv_sat_svp_to_qsat_vec
! Get saturation mass mixing ratio (over dry air) given pressure and SVP.
! Output is limited to the range 0-epsilo.
elemental function shr_wv_sat_svp_to_qmmr(es, p) result(qs)
real(rk), intent(in) :: es ! SVP
real(rk), intent(in) :: p ! Current pressure
real(rk) :: qs
! If pressure is less than SVP, set qs to maximum of 1.
if ( (p - es) <= es ) then
qs = epsilo
else
qs = epsilo*es / (p - es)
end if
end function shr_wv_sat_svp_to_qmmr
pure function shr_wv_sat_svp_to_qmmr_vec(n, es, p) result(qs)
integer, intent(in) :: n ! Size of input arrays
real(rk), intent(in) :: es(n) ! SVP
real(rk), intent(in) :: p(n) ! Current pressure
real(rk) :: qs(n)
integer :: i
! If pressure is less than SVP, set qs to maximum of 1.
do i = 1, n
if ( (p(i) - es(i)) <= es(i) ) then
qs(i) = epsilo
else
qs(i) = epsilo*es(i) / (p(i) - es(i))
end if
end do
end function shr_wv_sat_svp_to_qmmr_vec
elemental subroutine shr_wv_sat_qsat_liquid(t, p, es, qs, idx)
!------------------------------------------------------------------!
! Purpose: !
! Calculate SVP over water at a given temperature, and then !
! calculate and return saturation specific humidity. !
!------------------------------------------------------------------!
! Inputs
real(rk), intent(in) :: t ! Temperature
real(rk), intent(in) :: p ! Pressure
! Outputs
real(rk), intent(out) :: es ! Saturation vapor pressure
real(rk), intent(out) :: qs ! Saturation specific humidity
integer, intent(in), optional :: idx ! Scheme index
es = shr_wv_sat_svp_liquid(t, idx)
qs = shr_wv_sat_svp_to_qsat(es, p)
! Ensures returned es is consistent with limiters on qs.
es = min(es, p)
end subroutine shr_wv_sat_qsat_liquid
pure subroutine shr_wv_sat_qsat_liquid_vec(n, t, p, es, qs, idx)
!------------------------------------------------------------------!
! Purpose: !
! Calculate SVP over water at a given temperature, and then !
! calculate and return saturation specific humidity. !
!------------------------------------------------------------------!
! Inputs
integer, intent(in) :: n ! Size of input arrays
real(rk), intent(in) :: t(n) ! Temperature
real(rk), intent(in) :: p(n) ! Pressure
! Outputs
real(rk), intent(out) :: es(n) ! Saturation vapor pressure
real(rk), intent(out) :: qs(n) ! Saturation specific humidity
integer, intent(in), optional :: idx ! Scheme index
es = shr_wv_sat_svp_liquid(n, t, idx)
qs = shr_wv_sat_svp_to_qsat(n, es, p)
! Ensures returned es is consistent with limiters on qs.
es = min(es, p)
end subroutine shr_wv_sat_qsat_liquid_vec
elemental subroutine shr_wv_sat_qsat_ice(t, p, es, qs, idx)
!------------------------------------------------------------------!
! Purpose: !
! Calculate SVP over ice at a given temperature, and then !
! calculate and return saturation specific humidity. !
!------------------------------------------------------------------!
! Inputs
real(rk), intent(in) :: t ! Temperature
real(rk), intent(in) :: p ! Pressure
! Outputs
real(rk), intent(out) :: es ! Saturation vapor pressure
real(rk), intent(out) :: qs ! Saturation specific humidity
integer, intent(in), optional :: idx ! Scheme index
es = shr_wv_sat_svp_ice(t, idx)
qs = shr_wv_sat_svp_to_qsat(es, p)
! Ensures returned es is consistent with limiters on qs.
es = min(es, p)
end subroutine shr_wv_sat_qsat_ice
pure subroutine shr_wv_sat_qsat_ice_vec(n, t, p, es, qs, idx)
!------------------------------------------------------------------!
! Purpose: !
! Calculate SVP over ice at a given temperature, and then !
! calculate and return saturation specific humidity. !
!------------------------------------------------------------------!
! Inputs
integer, intent(in) :: n ! Size of input arrays
real(rk), intent(in) :: t(n) ! Temperature
real(rk), intent(in) :: p(n) ! Pressure
! Outputs
real(rk), intent(out) :: es(n) ! Saturation vapor pressure
real(rk), intent(out) :: qs(n) ! Saturation specific humidity
integer, intent(in), optional :: idx ! Scheme index
es = shr_wv_sat_svp_ice(n, t, idx)
qs = shr_wv_sat_svp_to_qsat(n, es, p)
! Ensures returned es is consistent with limiters on qs.
es = min(es, p)
end subroutine shr_wv_sat_qsat_ice_vec
elemental subroutine shr_wv_sat_qsat_mixed(t, p, es, qs, idx)
!------------------------------------------------------------------!
! Purpose: !
! Calculate SVP over ice at a given temperature, and then !
! calculate and return saturation specific humidity. !
!------------------------------------------------------------------!
! Inputs
real(rk), intent(in) :: t ! Temperature
real(rk), intent(in) :: p ! Pressure
! Outputs
real(rk), intent(out) :: es ! Saturation vapor pressure
real(rk), intent(out) :: qs ! Saturation specific humidity
integer, intent(in), optional :: idx ! Scheme index
es = shr_wv_sat_svp_mixed(t, idx)
qs = shr_wv_sat_svp_to_qsat(es, p)
! Ensures returned es is consistent with limiters on qs.
es = min(es, p)
end subroutine shr_wv_sat_qsat_mixed
pure subroutine shr_wv_sat_qsat_mixed_vec(n, t, p, es, qs, idx)
!------------------------------------------------------------------!
! Purpose: !
! Calculate SVP over ice at a given temperature, and then !
! calculate and return saturation specific humidity. !
!------------------------------------------------------------------!
! Inputs
integer, intent(in) :: n ! Size of input arrays
real(rk), intent(in) :: t(n) ! Temperature
real(rk), intent(in) :: p(n) ! Pressure
! Outputs
real(rk), intent(out) :: es(n) ! Saturation vapor pressure
real(rk), intent(out) :: qs(n) ! Saturation specific humidity
integer, intent(in), optional :: idx ! Scheme index
es = shr_wv_sat_svp_mixed(n, t, idx)
qs = shr_wv_sat_svp_to_qsat(n, es, p)
! Ensures returned es is consistent with limiters on qs.
es = min(es, p)
end subroutine shr_wv_sat_qsat_mixed_vec
!---------------------------------------------------------------------
! SVP INTERFACE FUNCTIONS
!---------------------------------------------------------------------
elemental function shr_wv_sat_svp_liquid(t, idx) result(es)
real(rk), intent(in) :: t
integer, intent(in), optional :: idx
real(rk) :: es
integer :: use_idx
if (present(idx)) then
use_idx = idx
else
use_idx = default_idx
end if
if (use_idx == default_idx .and. allocated(liquid_table)) then
es = lookup_svp_in_table(t, liquid_table_spec, liquid_table, &
shr_wv_sat_svp_liquid_no_table)
else
es = shr_wv_sat_svp_liquid_no_table(t, use_idx)
end if
end function shr_wv_sat_svp_liquid
pure function shr_wv_sat_svp_liquid_vec(n, t, idx) result(es)
integer, intent(in) :: n
real(rk), intent(in) :: t(n)
integer, intent(in), optional :: idx
real(rk) :: es(n)
integer :: use_idx
integer :: i
if (present(idx)) then
use_idx = idx
else
use_idx = default_idx
end if
if (use_idx == default_idx .and. allocated(liquid_table)) then
do i = 1, n
es(i) = lookup_svp_in_table(t(i), liquid_table_spec, liquid_table, &
shr_wv_sat_svp_liquid_no_table)
end do
else
do i = 1, n
es(i) = shr_wv_sat_svp_liquid_no_table(t(i), use_idx)
end do
end if
end function shr_wv_sat_svp_liquid_vec
pure function shr_wv_sat_svp_liquid_no_table(t, idx) result(es)
real(rk), intent(in) :: t
integer, intent(in) :: idx
real(rk) :: es
select case (idx)
case(GoffGratch_idx)
es = GoffGratch_svp_liquid(t)
case(MurphyKoop_idx)
es = MurphyKoop_svp_liquid(t)
case(Bolton_idx)
es = Bolton_svp_liquid(t)
case (Flatau_idx)
es = Flatau_svp_liquid(t)
case default
! Providing a correct index is an important precondition for these
! functions. Since we don’t have a way of signaling an error, produce an
! obviously unreasonable answer.
es = -huge(1._rk)
end select
end function shr_wv_sat_svp_liquid_no_table
elemental function shr_wv_sat_svp_ice(t, idx) result(es)
real(rk), intent(in) :: t
integer, intent(in), optional :: idx
real(rk) :: es
integer :: use_idx
if (present(idx)) then
use_idx = idx
else
use_idx = default_idx
end if
if (use_idx == default_idx .and. allocated(ice_table)) then
es = lookup_svp_in_table(t, ice_table_spec, ice_table, &
shr_wv_sat_svp_ice_no_table)
else
es = shr_wv_sat_svp_ice_no_table(t, use_idx)
end if
end function shr_wv_sat_svp_ice
pure function shr_wv_sat_svp_ice_vec(n, t, idx) result(es)
integer, intent(in) :: n
real(rk), intent(in) :: t(n)
integer, intent(in), optional :: idx
real(rk) :: es(n)
integer :: use_idx
integer :: i
if (present(idx)) then
use_idx = idx
else
use_idx = default_idx
end if
if (use_idx == default_idx .and. allocated(ice_table)) then
do i = 1, n
es(i) = lookup_svp_in_table(t(i), ice_table_spec, ice_table, &
shr_wv_sat_svp_ice_no_table)
end do
else
do i = 1, n
es(i) = shr_wv_sat_svp_ice_no_table(t(i), use_idx)
end do
end if
end function shr_wv_sat_svp_ice_vec
pure function shr_wv_sat_svp_ice_no_table(t, idx) result(es)
real(rk), intent(in) :: t
integer, intent(in) :: idx
real(rk) :: es
select case (idx)
case(GoffGratch_idx)
es = GoffGratch_svp_ice(t)
case(MurphyKoop_idx)
es = MurphyKoop_svp_ice(t)
case(Bolton_idx)
es = Bolton_svp_ice(t)
case (Flatau_idx)
es = Flatau_svp_ice(t)
case default
! Providing a correct index is an important precondition for these
! functions. Since we don’t have a way of signaling an error, produce an
! obviously unreasonable answer.
es = -huge(1._rk)
end select
end function shr_wv_sat_svp_ice_no_table
elemental function shr_wv_sat_svp_mixed(t, idx) result (es)
real(rk), intent(in) :: t
integer, intent(in), optional :: idx
real(rk) :: es
integer :: use_idx
if (present(idx)) then
use_idx = idx
else
use_idx = default_idx
end if
if (use_idx == default_idx .and. allocated(mixed_table)) then
es = lookup_svp_in_table(t, mixed_table_spec, mixed_table, &
shr_wv_sat_svp_mixed_no_table)
else
es = shr_wv_sat_svp_mixed_no_table(t, use_idx)
end if
end function shr_wv_sat_svp_mixed
pure function shr_wv_sat_svp_mixed_vec(n, t, idx) result (es)
integer, intent(in) :: n
real(rk), intent(in) :: t(n)
integer, intent(in), optional :: idx
real(rk) :: es(n)
integer :: use_idx
integer :: i
if (present(idx)) then
use_idx = idx
else
use_idx = default_idx
end if
if (use_idx == default_idx .and. allocated(mixed_table)) then
do i = 1, n
es(i) = lookup_svp_in_table(t(i), mixed_table_spec, mixed_table, &
shr_wv_sat_svp_mixed_no_table)
end do
else
es = shr_wv_sat_svp_mixed_no_table_vec(n, t, use_idx)
end if
end function shr_wv_sat_svp_mixed_vec
pure function shr_wv_sat_svp_mixed_no_table(t, idx) result (es)
real(rk), intent(in) :: t
integer, intent(in) :: idx
real(rk) :: es
real(rk) :: esice ! Saturation vapor pressure over ice
real(rk) :: weight ! Intermediate scratch variable for es transition
!
! Water
!
if (t >= (tmelt - ttrice)) then
es = shr_wv_sat_svp_liquid(t,idx)
else
es = 0.0_rk
end if
!
! Ice
!
if (t < tmelt) then
esice = shr_wv_sat_svp_ice(t,idx)
if ( (tmelt - t) > ttrice ) then
weight = 1.0_rk
else
weight = (tmelt - t)/ttrice
end if
es = weight*esice + (1.0_rk - weight)*es
end if
end function shr_wv_sat_svp_mixed_no_table
! The reason why we need a separate vector version for this function (but
! not the other “no_table” functions) is that even if the functions called
! are all inlined, we may still have a table lookup for the liquid/ice
! tables (rather than the mixed-phase one). That table lookup is not
! vectorizable, meaning that the above function can’t vectorize.
!
! Cripes this is ugly, though.
pure function shr_wv_sat_svp_mixed_no_table_vec(n, t, idx) result (es)
integer, intent(in) :: n
real(rk), intent(in) :: t(n)
integer, intent(in) :: idx
real(rk) :: es(n)
real(rk) :: esice ! Saturation vapor pressure over ice
real(rk) :: weight ! Intermediate scratch variable for es transition
integer :: i
!
! Water
!
if (idx == default_idx .and. allocated(liquid_table)) then
do i = 1, n
if (t(i) >= (tmelt - ttrice)) then
es(i) = lookup_svp_in_table(t(i), liquid_table_spec, liquid_table, &
shr_wv_sat_svp_liquid_no_table)
else
es(i) = 0.0_rk
end if
end do
else
do i = 1, n
if (t(i) >= (tmelt - ttrice)) then
es(i) = shr_wv_sat_svp_liquid_no_table(t(i), idx)
else
es(i) = 0.0_rk
end if
end do
end if
!
! Ice
!
if (idx == default_idx .and. allocated(ice_table)) then
do i = 1, n
if (t(i) < tmelt) then
esice = lookup_svp_in_table(t(i), ice_table_spec, ice_table, &
shr_wv_sat_svp_ice_no_table)
if ( (tmelt - t(i)) > ttrice ) then
weight = 1.0_rk
else
weight = (tmelt - t(i))/ttrice
end if
es(i) = weight*esice + (1.0_rk - weight)*es(i)
end if
end do
else
do i = 1, n
if (t(i) < tmelt) then
esice = shr_wv_sat_svp_ice_no_table(t(i), idx)
if ( (tmelt - t(i)) > ttrice ) then
weight = 1.0_rk
else
weight = (tmelt - t(i))/ttrice
end if
es(i) = weight*esice + (1.0_rk - weight)*es(i)
end if
end do
end if
end function shr_wv_sat_svp_mixed_no_table_vec
!---------------------------------------------------------------------
! SVP METHODS
!---------------------------------------------------------------------
! Use the lookup table
! Note that a function that takes a procedure argument can’t be elemental, but
! it must be pure to be called from the elemental interfaces above.
recursive pure function lookup_svp_in_table(t, table_spec, table, fallback) &
result(es)
! Temperature in Kelvin
real(rk), intent(in) :: t
! Table range specification
type(ShrWVSatTableSpec), intent(in) :: table_spec
! The table itself
real(rk), intent(in) :: table(table_spec%table_size)
! Fallback used when we’re outside the table bounds
interface
pure function fallback(t, idx) result(es)
import :: rk
real(rk), intent(in) :: t
integer, intent(in) :: idx
real(rk) :: es
end function fallback
end interface
! SVP in Pa
real(rk) :: es
integer :: idx
real(rk) :: residual
residual = (t - table_spec%minimum)/table_spec%spacing + 1._rk
idx = int(residual)
! Deal with the case where we’re outside the table bounds.
if (idx < 1 .or. idx+1 > table_spec%table_size) then
es = fallback(t, default_idx)
return
end if
! Now we want the “residual” to be how far this temperature is past the
! current index.
residual = residual - real(idx, rk)
! Just use linear interpolation. Some iterative methods might do better if we
! used a cubic.
es = table(idx) * (1._rk-residual) + table(idx+1) * residual
end function lookup_svp_in_table
! Goff & Gratch (1946)
pure function GoffGratch_svp_liquid(t) result(es)
real(rk), intent(in) :: t ! Temperature in Kelvin
real(rk) :: es ! SVP in Pa
! Boiling point of water at 1 atm (K)
! This is not really the most accurate value, but it is the one that the
! Goff & Gratch scheme was designed to use, so we hard-code it.
real(rk), parameter :: tboil = 373.16_rk
! uncertain below -70 C
es = 10._rk**(-7.90298_rk*(tboil/t-1._rk)+ &
5.02808_rklog10(tboil/t)- &
1.3816e-7_rk(10._rk**(11.344_rk*(1._rk-t/tboil))-1._rk)+ &
8.1328e-3_rk*(10._rk**(-3.49149_rk*(tboil/t-1._rk))-1._rk)+ &
log10(1013.246_rk))*100._rk
end function GoffGratch_svp_liquid
pure function GoffGratch_svp_ice(t) result(es)
real(rk), intent(in) :: t ! Temperature in Kelvin
real(rk) :: es ! SVP in Pa
! good down to -100 C
es = 10._rk**(-9.09718_rk*(h2otrip/t-1._rk)-3.56654_rk* &
log10(h2otrip/t)+0.876793_rk*(1._rk-t/h2otrip)+ &
log10(6.1071_rk))*100._rk
end function GoffGratch_svp_ice
! Murphy & Koop (2005)
pure function MurphyKoop_svp_liquid(t) result(es)
real(rk), intent(in) :: t ! Temperature in Kelvin
real(rk) :: es ! SVP in Pa
! (good for 123 < T < 332 K)
es = exp(54.842763_rk - (6763.22_rk / t) - (4.210_rk * log(t)) + &
(0.000367_rk * t) + (tanh(0.0415_rk * (t - 218.8_rk)) * &
(53.878_rk - (1331.22_rk / t) - (9.44523_rk * log(t)) + &
0.014025_rk * t)))
end function MurphyKoop_svp_liquid
pure function MurphyKoop_svp_ice(t) result(es)
real(rk), intent(in) :: t ! Temperature in Kelvin
real(rk) :: es ! SVP in Pa
! (good down to 110 K)
es = exp(9.550426_rk - (5723.265_rk / t) + (3.53068_rk * log(t)) &
- (0.00728332_rk * t))
end function MurphyKoop_svp_ice
! Taken from CLUBB, based on Bolton (1980).
pure function Bolton_svp_liquid(t) result(es)
real(rk), parameter :: c1 = 611.2_rk
real(rk), parameter :: c2 = 17.67_rk
real(rk), parameter :: c3 = 29.65_rk
real(rk), intent(in) :: t ! Temperature in Kelvin
real(rk) :: es ! SVP in Pa
es = c1exp( (c2(t - tmelt))/(t - c3) )
end function Bolton_svp_liquid
pure function Bolton_svp_ice(t) result(es)
real(rk), intent(in) :: t ! Temperature in Kelvin
real(rk) :: es ! SVP in Pa
es = exp( 27.93603_rk - (6111.72784_rk/t) + (0.15215_rk*log(t)) )
end function Bolton_svp_ice
! “Flatau” scheme modified from CLUBB, based on:
!
! ``Polynomial Fits to Saturation Vapor Pressure’’ Flatau, Walko,
! and Cotton. (1992) Journal of Applied Meteorology, Vol. 31,
! pp. 1507–1513
pure function Flatau_svp_liquid(t) result(es)
real(rk), intent(in) :: t ! Temperature in Kelvin
real(rk) :: es ! SVP in Pa
real(rk), dimension(9), parameter :: coef = [ &
6.11583699E+02_rk, 4.44606896E+01_rk, 1.43177157E+00_rk, &
2.64224321E-02_rk, 2.99291081E-04_rk, 2.03154182E-06_rk, &
7.02620698E-09_rk, 3.79534310E-12_rk,-3.21582393E-14_rk ]
real(rk), parameter :: min_T_in_C = -85._rk
real(rk) :: T_in_C
T_in_C = max(t - tmelt, min_T_in_C)
es = coef(1) + T_in_C * (coef(2) + T_in_C * (coef(3) + T_in_C * &
(coef(4) + T_in_C * (coef(5) + T_in_C * (coef(6) + T_in_C * &
(coef(7) + T_in_C * (coef(8) + T_in_C * coef(9))))))))
end function Flatau_svp_liquid
pure function Flatau_svp_ice(t) result(es)
real(rk), intent(in) :: t ! Temperature in Kelvin
real(rk) :: es ! SVP in Pa
real(rk), dimension(9), parameter :: coef = [ &
6.09868993E+02_rk, 4.99320233E+01_rk, 1.84672631E+00_rk, &
4.02737184E-02_rk, 5.65392987E-04_rk, 5.21693933E-06_rk, &
3.07839583E-08_rk, 1.05785160E-10_rk, 1.61444444E-13_rk ]
real(rk), parameter :: min_T_in_C = -90._rk
real(rk) :: T_in_C
T_in_C = max(t - tmelt, min_T_in_C)
es = coef(1) + T_in_C * (coef(2) + T_in_C * (coef(3) + T_in_C * &
(coef(4) + T_in_C * (coef(5) + T_in_C * (coef(6) + T_in_C * &
(coef(7) + T_in_C * (coef(8) + T_in_C * coef(9))))))))
end function Flatau_svp_ice
end module shr_wv_sat_mod
When I try to compile it with PGF90 18.4, I get the following errors:
PGF90-S-0074-Illegal number or type of arguments to shr_wv_sat_make_one_table - arguments of shr_wv_sat_svp_liquid_no_table and svp_function do not agree (/Users/mark/cesm2.0.1/cime/src/share/util/shr_wv_sat_mod.F90: 299)
PGF90-S-0074-Illegal number or type of arguments to shr_wv_sat_make_one_table - arguments of shr_wv_sat_svp_ice_no_table and svp_function do not agree (/Users/mark/cesm2.0.1/cime/src/share/util/shr_wv_sat_mod.F90: 305)
PGF90-S-0074-Illegal number or type of arguments to shr_wv_sat_make_one_table - arguments of shr_wv_sat_svp_mixed_no_table and svp_function do not agree (/Users/mark/cesm2.0.1/cime/src/share/util/shr_wv_sat_mod.F90: 311)
Thanks!
Mark Branson