diff --git a/bld/configure b/bld/configure
index 9716d92579..3fb0bb74a1 100755
--- a/bld/configure
+++ b/bld/configure
@@ -1099,6 +1099,11 @@ elsif ($rad_pkg =~ m/rrtmg/) {
die "configure ERROR: radiation package: $rad_pkg is not compatible\n".
" with physics package $phys_pkg\n";
}
+
+ # RRTMGP not currently working with CARMA
+ if ($rad_pkg eq 'rrtmgp' and $carma_pkg ne 'none') {
+ die "configure ERROR: The CARMA microphysics package does not currently work with RRTMGP\n";
+ }
}
$cfg_ref->set('rad', $rad_pkg);
diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml
index 1061073d4d..69d80f54e5 100644
--- a/cime_config/testdefs/testlist_cam.xml
+++ b/cime_config/testdefs/testlist_cam.xml
@@ -199,12 +199,13 @@
-
+
+
@@ -1795,11 +1796,11 @@
-
+
-
+
@@ -1813,11 +1814,11 @@
-
+
-
+
@@ -2765,10 +2766,11 @@
-
+
+
@@ -2865,6 +2867,7 @@
+
diff --git a/doc/ChangeLog b/doc/ChangeLog
index cac91effcd..3c6f232433 100644
--- a/doc/ChangeLog
+++ b/doc/ChangeLog
@@ -11,6 +11,12 @@ Purpose of changes (include the issue number and title text for each relevant Gi
#255 - Provide RRTMGP as a radiation parameterization
https://github.com/ESCOMP/CAM/issues/255
+Miscellaneous:
+. The 1850_cam5.xml use case file was added back to the source code to
+ facilitate running the F1850 compset with CAM5. That discussion is in
+ issue #393.
+
+
Describe any changes made to build system:
. '-rad' argument to configure accepts the values 'rrtmgp' and 'rrtmgp_gpu'
to build the RRTMGP code for CPUs or for GPUs.
@@ -48,11 +54,16 @@ cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/user_nl_clm
. for adding RRTMGP to tests
src/physics/cam/cloud_rad_props.F90
-src/physics/cam/ebert_curry.F90
-src/physics/cam/oldcloud.F90
-src/physics/cam/slingo.F90
-. these 4 files are shared cloud optics code moved here from src/physics/rrtmg/.
-. remove unused code, cleanup unused vars
+src/physics/cam/ebert_curry_ice_optics.F90
+src/physics/cam/oldcloud_optics.F90
+src/physics/cam/slingo_liq_optics.F90
+. these 4 files are shared cloud optics code moved here from
+ src/physics/rrtmg/ with the following name changes:
+ - ebert_curry.F90 -> ebert_curry_ice_optics.F90
+ - oldcloud.F90 -> oldcloud_optics.F90
+ - slingo.F90 -> slingo_liq_optics.F90
+. remove unused code, cleanup unused vars, improve endrun messages
+. module names changed to match file names.
src/physics/rrtmgp/mcica_subcol_gen.F90
src/physics/rrtmgp/radconstants.F90
@@ -83,6 +94,7 @@ bld/configure
. '-rad rrtmgp_gpu' sets a flag used to add the filepaths for the GPU code
versions to the Filepath file. The '_gpu' suffix is removed before
setting the parameter value for 'rad' in the config_cache.xml file.
+. check to disallow CARMA + RRTMGP
bld/namelist_files/namelist_defaults_cam.xml
. the aersol and cloud optics datasets for RRTMG are being reused for
@@ -93,13 +105,14 @@ bld/namelist_files/namelist_definition.xml
. add variables rrtmgp_coefs_lw_file and rrtmgp_coefs_sw_file to contain
filepaths for the RRTMGP coefficients files.
-cime_config/testdefs/testlist_cam.xml (aux_cam)
+cime_config/testdefs/testlist_cam.xml
. add aux_cam tests:
- ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.cheyenne_intel.cam-outfrq9s_rrtmgp
- SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.cheyenne_intel.cam-outfrq9s_rrtmgp
- SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.cheyenne_intel.cam-outfrq9s_rrtmgp
+ ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp
+ SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp
ERP_D_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_rrtmgp
SMS_Ld5.f09_f09_mg17.PC6.izumi_gnu.cam-cam6_port_f09_rrtmgp
+. add prealpha test:
+ SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s_rrtmgp
src/chemistry/utils/solar_data.F90
. add solar_htng_spctrl_scl to log file output
@@ -134,6 +147,9 @@ src/physics/camrt/radconstants.F90
src/physics/rrtmg/radconstants.F90
. parameters ot_length and nrh moved to phys_props
+src/physics/rrtmg/radiation.F90
+. ebert_curry -> ebert_curry_ice_optics
+
src/physics/simple/radconstants.F90
. parameters ot_length and nrh moved to phys_props
. add dummy interface for get_sw_spectral_boundaries
diff --git a/src/physics/cam/cloud_rad_props.F90 b/src/physics/cam/cloud_rad_props.F90
index 1e518a47d7..9c8a1a3562 100644
--- a/src/physics/cam/cloud_rad_props.F90
+++ b/src/physics/cam/cloud_rad_props.F90
@@ -10,12 +10,11 @@ module cloud_rad_props
use constituents, only: cnst_get_ind
use radconstants, only: nswbands, nlwbands, idx_sw_diag
use rad_constituents, only: iceopticsfile, liqopticsfile
-use oldcloud, only: oldcloud_init, oldcloud_lw, &
+use oldcloud_optics, only: oldcloud_init, oldcloud_lw, &
old_liq_get_rad_props_lw, old_ice_get_rad_props_lw
-
-use slingo, only: slingo_rad_props_init
-use ebert_curry, only: ec_rad_props_init, scalefactor
+use slingo_liq_optics, only: slingo_rad_props_init
+use ebert_curry_ice_optics, only: ec_rad_props_init, scalefactor
use interpolate_data, only: interp_type, lininterp_init, lininterp, &
extrap_method_bndry, lininterp_finish
@@ -101,6 +100,7 @@ subroutine cloud_rad_props_init()
integer :: d_id, ext_sw_ice_id, ssa_sw_ice_id, asm_sw_ice_id, abs_lw_ice_id
integer :: err
+ character(len=*), parameter :: sub = 'cloud_rad_props_init'
liquidfile = liqopticsfile
icefile = iceopticsfile
@@ -131,11 +131,11 @@ subroutine cloud_rad_props_init()
call handle_ncerr(nf90_inq_dimid( ncid, 'lw_band', dimid), 'getting lw_band dim')
call handle_ncerr(nf90_inquire_dimension( ncid, dimid, len=f_nlwbands), 'getting n lw bands')
- if (f_nlwbands /= nlwbands) call endrun('number of lw bands does not match')
+ if (f_nlwbands /= nlwbands) call endrun(sub//': number of lw bands does not match')
call handle_ncerr(nf90_inq_dimid( ncid, 'sw_band', dimid), 'getting sw_band_dim')
call handle_ncerr(nf90_inquire_dimension( ncid, dimid, len=f_nswbands), 'getting n sw bands')
- if (f_nswbands /= nswbands) call endrun('number of sw bands does not match')
+ if (f_nswbands /= nswbands) call endrun(sub//': number of sw bands does not match')
call handle_ncerr(nf90_inq_dimid( ncid, 'mu', mudimid), 'getting mu dim')
call handle_ncerr(nf90_inquire_dimension( ncid, mudimid, len=nmu), 'getting n mu samples')
@@ -210,12 +210,12 @@ subroutine cloud_rad_props_init()
call handle_ncerr(nf90_inq_dimid( ncid, 'lw_band', dimid), 'getting lw_band dim')
call handle_ncerr(nf90_inquire_dimension( ncid, dimid, len=f_nlwbands), 'getting n lw bands')
if (f_nlwbands /= nlwbands) then
- call endrun('number of lw bands does not match')
+ call endrun(sub//': number of lw bands does not match')
end if
call handle_ncerr(nf90_inq_dimid( ncid, 'sw_band', dimid), 'getting sw_band_dim')
call handle_ncerr(nf90_inquire_dimension( ncid, dimid, len=f_nswbands), 'getting n sw bands')
if (f_nswbands /= nswbands) then
- call endrun('number of sw bands does not match')
+ call endrun(sub//': number of sw bands does not match')
end if
call handle_ncerr(nf90_inq_dimid( ncid, 'd_eff', d_dimid), 'getting deff dim')
call handle_ncerr(nf90_inquire_dimension( ncid, d_dimid, len=n_g_d), 'getting n deff samples')
@@ -347,7 +347,7 @@ subroutine get_ice_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f)
real(r8),intent(out) :: tau (nswbands,pcols,pver) ! extinction optical depth
real(r8),intent(out) :: tau_w (nswbands,pcols,pver) ! single scattering albedo * tau
- real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! assymetry parameter * tau * w
+ real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! asymetry parameter * tau * w
real(r8),intent(out) :: tau_w_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w
real(r8), pointer :: iciwpth(:,:), dei(:,:)
@@ -370,7 +370,7 @@ subroutine get_snow_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f)
real(r8),intent(out) :: tau (nswbands,pcols,pver) ! extinction optical depth
real(r8),intent(out) :: tau_w (nswbands,pcols,pver) ! single scattering albedo * tau
- real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! assymetry parameter * tau * w
+ real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! asymetry parameter * tau * w
real(r8),intent(out) :: tau_w_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w
real(r8), pointer :: icswpth(:,:), des(:,:)
@@ -393,12 +393,13 @@ subroutine get_grau_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f)
real(r8),intent(out) :: tau (nswbands,pcols,pver) ! extinction optical depth
real(r8),intent(out) :: tau_w (nswbands,pcols,pver) ! single scattering albedo * tau
- real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! assymetry parameter * tau * w
+ real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! asymetry parameter * tau * w
real(r8),intent(out) :: tau_w_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w
real(r8), pointer :: icgrauwpth(:,:), degrau(:,:)
integer :: i,k
+ character(len=*), parameter :: sub = 'get_grau_optics_sw'
! This does the same thing as get_ice_optics_sw, except with a different
! water path and effective diameter.
@@ -419,7 +420,7 @@ subroutine get_grau_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f)
enddo
else
- call endrun('ERROR: Get_grau_optics_sw called when graupel properties not supported')
+ call endrun(sub//': ERROR: Get_grau_optics_sw called when graupel properties not supported')
end if
end subroutine get_grau_optics_sw
@@ -520,6 +521,7 @@ subroutine grau_cloud_get_rad_props_lw(state, pbuf, abs_od)
real(r8), intent(out) :: abs_od(nlwbands,pcols,pver)
real(r8), pointer :: icgrauwpth(:,:), degrau(:,:)
+ character(len=*), parameter :: sub = 'grau_cloud_get_rad_props_lw'
! This does the same thing as ice_cloud_get_rad_props_lw, except with a
! different water path and effective diameter.
@@ -529,7 +531,7 @@ subroutine grau_cloud_get_rad_props_lw(state, pbuf, abs_od)
call interpolate_ice_optics_lw(state%ncol,icgrauwpth, degrau, abs_od)
else
- call endrun('ERROR: Grau_cloud_get_rad_props_lw called when graupel &
+ call endrun(sub//': ERROR: Grau_cloud_get_rad_props_lw called when graupel &
&properties not supported')
end if
@@ -566,7 +568,7 @@ subroutine interpolate_ice_optics_sw(ncol, iciwpth, dei, tau, tau_w, &
real(r8),intent(out) :: tau (nswbands,pcols,pver) ! extinction optical depth
real(r8),intent(out) :: tau_w (nswbands,pcols,pver) ! single scattering albedo * tau
- real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! assymetry parameter * tau * w
+ real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! asymetry parameter * tau * w
real(r8),intent(out) :: tau_w_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w
type(interp_type) :: dei_wgts
diff --git a/src/physics/cam/ebert_curry.F90 b/src/physics/cam/ebert_curry_ice_optics.F90
similarity index 99%
rename from src/physics/cam/ebert_curry.F90
rename to src/physics/cam/ebert_curry_ice_optics.F90
index 8a47714c19..377d15de4a 100644
--- a/src/physics/cam/ebert_curry.F90
+++ b/src/physics/cam/ebert_curry_ice_optics.F90
@@ -1,4 +1,4 @@
-module ebert_curry
+module ebert_curry_ice_optics
use shr_kind_mod, only: r8 => shr_kind_r8
@@ -261,4 +261,4 @@ end subroutine ec_ice_get_rad_props_lw
!==============================================================================
-end module ebert_curry
+end module ebert_curry_ice_optics
diff --git a/src/physics/cam/oldcloud.F90 b/src/physics/cam/oldcloud_optics.F90
similarity index 94%
rename from src/physics/cam/oldcloud.F90
rename to src/physics/cam/oldcloud_optics.F90
index d34794e4f1..bf53856ad6 100644
--- a/src/physics/cam/oldcloud.F90
+++ b/src/physics/cam/oldcloud_optics.F90
@@ -1,4 +1,4 @@
-module oldcloud
+module oldcloud_optics
!------------------------------------------------------------------------------------------------
!------------------------------------------------------------------------------------------------
@@ -10,7 +10,7 @@ module oldcloud
use constituents, only: cnst_get_ind
use physconst, only: gravit
use radconstants, only: nlwbands
-use ebert_curry, only: scalefactor
+use ebert_curry_ice_optics, only: scalefactor
use cam_abortutils, only: endrun
@@ -79,8 +79,6 @@ subroutine oldcloud_init()
call cnst_get_ind('CLDICE', ixcldice)
call cnst_get_ind('CLDLIQ', ixcldliq)
- return
-
end subroutine oldcloud_init
!==============================================================================
@@ -106,10 +104,8 @@ subroutine oldcloud_lw(state,pbuf,cld_abs_od,oldwp)
integer :: ncol, itim_old, lwband, i, k, lchnk
real(r8), pointer, dimension(:,:) :: iclwpth, iciwpth
- real(r8) :: kabs, kabsi
- real(r8) kabsl ! longwave liquid absorption coeff (m**2/g)
- parameter (kabsl = 0.090361_r8)
-
+ real(r8) :: kabs, kabsi
+ real(r8), parameter :: kabsl = 0.090361_r8 ! longwave liquid absorption coeff (m**2/g)
ncol = state%ncol
@@ -152,7 +148,6 @@ subroutine oldcloud_lw(state,pbuf,cld_abs_od,oldwp)
!in range of 13 > rei > 130 micron (Ebert and Curry 92)
kabsi = 0.005_r8 + 1._r8/min(max(13._r8,scalefactor*rei(i,k)),130._r8)
kabs = kabsl*(1._r8-ficemr(i,k)) + kabsi*ficemr(i,k)
- !emis(i,k) = 1._r8 - exp(-1.66_r8*kabs*clwp(i,k))
cldtau(i,k) = kabs*cwp(i,k)
end do
end do
@@ -185,8 +180,7 @@ subroutine old_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp)
integer :: ncol, itim_old, lwband, i, k, lchnk
real(r8) :: kabs, kabsi
- real(r8) kabsl ! longwave liquid absorption coeff (m**2/g)
- parameter (kabsl = 0.090361_r8)
+ real(r8), parameter :: kabsl = 0.090361_r8 ! longwave liquid absorption coeff (m**2/g)
real(r8), pointer, dimension(:,:) :: iclwpth, iciwpth
@@ -234,11 +228,10 @@ subroutine old_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp)
!in range of 13 > rei > 130 micron (Ebert and Curry 92)
kabsi = 0.005_r8 + 1._r8/min(max(13._r8,scalefactor*rei(i,k)),130._r8)
kabs = kabsl*(1._r8-ficemr(i,k)) ! + kabsi*ficemr(i,k)
- !emis(i,k) = 1._r8 - exp(-1.66_r8*kabs*clwp(i,k))
cldtau(i,k) = kabs*cwp(i,k)
end do
end do
-!
+
do lwband = 1,nlwbands
abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver)
enddo
@@ -267,10 +260,8 @@ subroutine old_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp)
real(r8), pointer, dimension(:,:) :: rei
integer :: ncol, itim_old, lwband, i, k, lchnk
- real(r8) :: kabs, kabsi
-
- real(r8) kabsl ! longwave liquid absorption coeff (m**2/g)
- parameter (kabsl = 0.090361_r8)
+ real(r8) :: kabs, kabsi
+ real(r8), parameter :: kabsl = 0.090361_r8 ! longwave liquid absorption coeff (m**2/g)
real(r8), pointer, dimension(:,:) :: iclwpth, iciwpth
@@ -318,11 +309,10 @@ subroutine old_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp)
!in range of 13 > rei > 130 micron (Ebert and Curry 92)
kabsi = 0.005_r8 + 1._r8/min(max(13._r8,scalefactor*rei(i,k)),130._r8)
kabs = kabsi*ficemr(i,k) ! kabsl*(1._r8-ficemr(i,k)) + kabsi*ficemr(i,k)
- !emis(i,k) = 1._r8 - exp(-1.66_r8*kabs*clwp(i,k))
cldtau(i,k) = kabs*cwp(i,k)
end do
end do
-!
+
do lwband = 1,nlwbands
abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver)
enddo
@@ -331,4 +321,4 @@ end subroutine old_ice_get_rad_props_lw
!==============================================================================
-end module oldcloud
+end module oldcloud_optics
diff --git a/src/physics/cam/slingo.F90 b/src/physics/cam/slingo_liq_optics.F90
similarity index 99%
rename from src/physics/cam/slingo.F90
rename to src/physics/cam/slingo_liq_optics.F90
index 80d42733b2..28b97920e8 100644
--- a/src/physics/cam/slingo.F90
+++ b/src/physics/cam/slingo_liq_optics.F90
@@ -1,4 +1,4 @@
-module slingo
+module slingo_liq_optics
!------------------------------------------------------------------------------------------------
! Implements Slingo Optics for MG/RRTMG for liquid clouds and
@@ -281,4 +281,4 @@ subroutine slingo_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp)
end subroutine slingo_liq_get_rad_props_lw
-end module slingo
+end module slingo_liq_optics
diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90
index 4ca347d749..3b47e8c2ad 100644
--- a/src/physics/rrtmg/radiation.F90
+++ b/src/physics/rrtmg/radiation.F90
@@ -728,8 +728,8 @@ subroutine radiation_tend( &
ice_cloud_get_rad_props_lw, cloud_rad_props_get_lw, &
grau_cloud_get_rad_props_lw, get_grau_optics_sw, &
snow_cloud_get_rad_props_lw, get_snow_optics_sw
- use slingo, only: slingo_liq_get_rad_props_lw, slingo_liq_optics_sw
- use ebert_curry, only: ec_ice_optics_sw, ec_ice_get_rad_props_lw
+ use slingo_liq_optics, only: slingo_liq_get_rad_props_lw, slingo_liq_optics_sw
+ use ebert_curry_ice_optics, only: ec_ice_optics_sw, ec_ice_get_rad_props_lw
use rad_solar_var, only: get_variability
use radsw, only: rad_rrtmg_sw
diff --git a/src/physics/rrtmgp/mcica_subcol_gen.F90 b/src/physics/rrtmgp/mcica_subcol_gen.F90
index f25732c729..ccd414fd5f 100644
--- a/src/physics/rrtmgp/mcica_subcol_gen.F90
+++ b/src/physics/rrtmgp/mcica_subcol_gen.F90
@@ -53,7 +53,6 @@ subroutine mcica_subcol_lw( &
! number of subcolumns
! arguments
- ! class(ty_gas_optics), intent(in) :: kdist ! spectral information ! Wrong?
class(ty_gas_optics_rrtmgp), intent(in) :: kdist ! spectral information
integer, intent(in) :: nbnd ! number of spectral bands
integer, intent(in) :: ngpt ! number of subcolumns (g-point intervals)
@@ -169,7 +168,6 @@ subroutine mcica_subcol_sw( &
! number of subcolumns
! arguments
- ! class(ty_gas_optics), intent(in) :: kdist ! spectral information ! Wrong?
class(ty_gas_optics_rrtmgp), intent(in) :: kdist ! spectral information
integer, intent(in) :: nbnd ! number of spectral bands
integer, intent(in) :: ngpt ! number of subcolumns (g-point intervals)
diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90
index e414771568..06dccde2b8 100644
--- a/src/physics/rrtmgp/radconstants.F90
+++ b/src/physics/rrtmgp/radconstants.F90
@@ -37,7 +37,7 @@ module radconstants
integer, public, protected :: idx_sw_cloudsim = -1 ! band contains 670-nm wave (for COSP)
integer, public, protected :: idx_lw_cloudsim = -1 ! band contains 10.5 micron wave (for COSP)
-! GASES TREATED BY RADIATION (line spectrae)
+! GASES TREATED BY RADIATION (line spectra)
! These names are recognized by RRTMGP. They are in the coefficients files as
! lower case strings. These upper case names are used by CAM's namelist and
! rad_constituents module.
@@ -73,6 +73,7 @@ subroutine set_wavenumber_bands(kdist_sw, kdist_lw)
type(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw
! Local variables
+ integer :: istat
real(r8), allocatable :: values(:,:)
character(len=128) :: errmsg
@@ -95,7 +96,10 @@ subroutine set_wavenumber_bands(kdist_sw, kdist_lw)
nlwgpts = kdist_lw%get_ngpt()
! SW band bounds in cm^-1
- allocate( values(2,nswbands) )
+ allocate( values(2,nswbands), stat=istat )
+ if (istat/=0) then
+ call endrun(sub//': ERROR allocating array: values(2,nswbands)')
+ end if
values = kdist_sw%get_band_lims_wavenumber()
wavenumber_low_shortwave = values(1,:)
wavenumber_high_shortwave = values(2,:)
@@ -109,7 +113,10 @@ subroutine set_wavenumber_bands(kdist_sw, kdist_lw)
deallocate(values)
! LW band bounds in cm^-1
- allocate( values(2,nlwbands) )
+ allocate( values(2,nlwbands), stat=istat )
+ if (istat/=0) then
+ call endrun(sub//': ERROR allocating array: values(2,nlwbands)')
+ end if
values = kdist_lw%get_band_lims_wavenumber()
wavenumber_low_longwave = values(1,:)
wavenumber_high_longwave = values(2,:)
@@ -233,6 +240,10 @@ function get_band_index_by_value(swlw, targetvalue, units) result(ans)
real(r8) :: tgt
integer :: nbnds, i
+ character(len=128) :: errmsg
+ character(len=*), parameter :: sub = 'get_band_index_by_value'
+ !----------------------------------------------------------------------------
+
select case (swlw)
case ('sw','SW','shortwave')
nbnds = nswbands
@@ -273,7 +284,8 @@ function get_band_index_by_value(swlw, targetvalue, units) result(ans)
end do
if (ans == 0) then
- call endrun('radconstants.F90: get_band_index_by_value: band not found: ')
+ write(errmsg,'(f10.3,a,a)') targetvalue, ' ', trim(units)
+ call endrun(sub//': band not found containing wave: '//trim(errmsg))
end if
end function get_band_index_by_value
diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90
index 5af989e7fe..d1b5603301 100644
--- a/src/physics/rrtmgp/radiation.F90
+++ b/src/physics/rrtmgp/radiation.F90
@@ -67,7 +67,6 @@ module radiation
public :: &
radiation_readnl, &! read namelist variables
radiation_register, &! registers radiation physics buffer fields
- radiation_nextsw_cday, &! calendar day of next radiation calculation
radiation_do, &! query which radiation calcs are done this timestep
radiation_init, &! initialization
radiation_define_restart, &! define variables for restart
@@ -107,8 +106,8 @@ module radiation
real(r8) :: flux_sw_dn(pcols,pverp) ! downward flux
real(r8) :: flux_sw_clr_dn(pcols,pverp) ! downward clearsky flux
- real(r8) :: flux_lw_up(pcols,pverp) ! upward shortwave flux on interfaces
- real(r8) :: flux_lw_clr_up(pcols,pverp) ! upward shortwave clearsky flux
+ real(r8) :: flux_lw_up(pcols,pverp) ! upward longwave flux on interfaces
+ real(r8) :: flux_lw_clr_up(pcols,pverp) ! upward longwave clearsky flux
real(r8) :: flux_lw_dn(pcols,pverp) ! downward flux
real(r8) :: flux_lw_clr_dn(pcols,pverp) ! downward clearsky flux
@@ -221,13 +220,14 @@ subroutine radiation_readnl(nlfile)
use namelist_utils, only: find_group_name
use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical, &
- mpi_character
+ mpi_character, mpi_real8
character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input
! Local variables
integer :: unitn, ierr
integer :: dtime ! timestep size
+ character(len=32) :: errmsg
character(len=*), parameter :: sub = 'radiation_readnl'
character(len=cl) :: rrtmgp_coefs_lw_file, rrtmgp_coefs_sw_file
@@ -244,7 +244,8 @@ subroutine radiation_readnl(nlfile)
if (ierr == 0) then
read(unitn, radiation_nl, iostat=ierr)
if (ierr /= 0) then
- call endrun(sub//': ERROR reading namelist')
+ write(errmsg,'(a,i5)') 'iostat =', ierr
+ call endrun(sub//': ERROR reading namelist: '//trim(errmsg))
end if
end if
close(unitn)
@@ -267,7 +268,7 @@ subroutine radiation_readnl(nlfile)
if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: spectralflux")
call mpi_bcast(use_rad_uniform_angle, 1, mpi_logical, mstrid, mpicom, ierr)
if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_rad_uniform_angle")
- call mpi_bcast(rad_uniform_angle, 1, mpi_logical, mstrid, mpicom, ierr)
+ call mpi_bcast(rad_uniform_angle, 1, mpi_real8, mstrid, mpicom, ierr)
if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: rad_uniform_angle")
call mpi_bcast(graupel_in_rad, 1, mpi_logical, mstrid, mpicom, ierr)
if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: graupel_in_rad")
@@ -379,7 +380,8 @@ end function radiation_do
real(r8) function radiation_nextsw_cday()
- ! Return calendar day of next sw radiation calculation
+ ! If a SW radiation calculation will be done on the next time-step, then return
+ ! the calendar day of that time-step. Otherwise return -1.0
! Local variables
integer :: nstep ! timestep counter
@@ -440,7 +442,7 @@ subroutine radiation_init(pbuf2d)
! temperature, water vapor, cloud ice and cloud
! liquid budgets.
integer :: history_budget_histfile_num ! history file number for budget fields
- integer :: ierr
+ integer :: ierr, istat
integer :: dtime
@@ -520,15 +522,15 @@ subroutine radiation_init(pbuf2d)
! "irad_always" is number of time steps to execute radiation continuously from
! start of initial OR restart run
- nstep = get_nstep()
+ nstep = get_nstep()
if (irad_always > 0) then
- nstep = get_nstep()
irad_always = irad_always + nstep
end if
if (docosp) call cospsimulator_intr_init()
- allocate(cosp_cnt(begchunk:endchunk))
+ allocate(cosp_cnt(begchunk:endchunk), stat=istat)
+ call check_allocate(istat, sub, 'cosp_cnt')
if (is_first_restart_step()) then
cosp_cnt(begchunk:endchunk) = cosp_cnt_init
else
@@ -858,7 +860,7 @@ subroutine radiation_tend( &
! if the argument is not present
logical :: write_output
- integer :: i, k
+ integer :: i, k, istat
integer :: lchnk, ncol
logical :: dosw, dolw
integer :: icall ! loop index for climate/diagnostic radiation calls
@@ -982,7 +984,8 @@ subroutine radiation_tend( &
rd => rd_out
write_output = .false.
else
- allocate(rd)
+ allocate(rd, stat=istat)
+ call check_allocate(istat, sub, 'rd')
write_output = .true.
end if
@@ -1078,9 +1081,11 @@ subroutine radiation_tend( &
allocate( &
t_sfc(ncol), emis_sfc(nlwbands,ncol), toa_flux(nday,nswgpts), &
- t_rad(ncol,nlay), pmid_rad(ncol,nlay), pint_rad(ncol,nlay+1), &
- t_day(nday,nlay), pmid_day(nday,nlay), pint_day(nday,nlay+1), &
- coszrs_day(nday), alb_dir(nswbands,nday), alb_dif(nswbands,nday) )
+ t_rad(ncol,nlay), pmid_rad(ncol,nlay), pint_rad(ncol,nlay+1), &
+ t_day(nday,nlay), pmid_day(nday,nlay), pint_day(nday,nlay+1), &
+ coszrs_day(nday), alb_dir(nswbands,nday), alb_dif(nswbands,nday), &
+ stat=istat)
+ call check_allocate(istat, sub, 't_sfc,..,alb_dif')
! Prepares state variables, daylit columns, albedos for RRTMGP
call rrtmgp_set_state( &
@@ -1282,9 +1287,8 @@ subroutine radiation_tend( &
end if ! if (dolw)
deallocate( &
- t_sfc, emis_sfc, t_rad, pmid_rad, pint_rad, &
- t_day, pmid_day, pint_day, coszrs_day, alb_dir, &
- alb_dif)
+ t_sfc, emis_sfc, toa_flux, t_rad, pmid_rad, pint_rad, &
+ t_day, pmid_day, pint_day, coszrs_day, alb_dir, alb_dif)
!================!
! COSP simulator !
@@ -1573,7 +1577,7 @@ subroutine heating_rate(type, ncol, flux_net, hrate)
do k = ktopcam, pver
! (flux divergence as bottom-MINUS-top) * g/dp
hrate(:ncol,k) = (flux_net(:ncol,k+1) - flux_net(:ncol,k)) * &
- gravit / state%pdel(:ncol,k)
+ gravit * state%rpdel(:ncol,k)
end do
case ('SW')
@@ -1581,7 +1585,7 @@ subroutine heating_rate(type, ncol, flux_net, hrate)
do k = ktopcam, pver
! top - bottom
hrate(:ncol,k) = (flux_net(:ncol,k) - flux_net(:ncol,k+1)) * &
- gravit / state%pdel(:ncol,k)
+ gravit * state%rpdel(:ncol,k)
end do
end select
@@ -1772,7 +1776,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
integer :: i
integer :: did, vid
- integer :: ierr
+ integer :: ierr, istat
character(32), dimension(:), allocatable :: gas_names
integer, dimension(:,:,:), allocatable :: key_species
@@ -1895,35 +1899,40 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
! Get variables
! names of absorbing gases
- allocate(gas_names(absorber))
+ allocate(gas_names(absorber), stat=istat)
+ call check_allocate(istat, sub, 'gas_names')
ierr = pio_inq_varid(fh, 'gas_names', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': gas_names not found')
ierr = pio_get_var(fh, vid, gas_names)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading gas_names')
! key species pair for each band
- allocate(key_species(2,atmos_layer,bnd))
+ allocate(key_species(2,atmos_layer,bnd), stat=istat)
+ call check_allocate(istat, sub, 'key_species')
ierr = pio_inq_varid(fh, 'key_species', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': key_species not found')
ierr = pio_get_var(fh, vid, key_species)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading key_species')
! beginning and ending gpoint for each band
- allocate(band2gpt(2,bnd))
+ allocate(band2gpt(2,bnd), stat=istat)
+ call check_allocate(istat, sub, 'band2gpt')
ierr = pio_inq_varid(fh, 'bnd_limits_gpt', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': bnd_limits_gpt not found')
ierr = pio_get_var(fh, vid, band2gpt)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading bnd_limits_gpt')
! beginning and ending wavenumber for each band
- allocate(band_lims_wavenum(2,bnd))
+ allocate(band_lims_wavenum(2,bnd), stat=istat)
+ call check_allocate(istat, sub, 'band_lims_wavenum')
ierr = pio_inq_varid(fh, 'bnd_limits_wavenumber', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': bnd_limits_wavenumber not found')
ierr = pio_get_var(fh, vid, band_lims_wavenum)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading bnd_limits_wavenumber')
! pressures [hPa] for reference atmosphere; press_ref(# reference layers)
- allocate(press_ref(pressure))
+ allocate(press_ref(pressure), stat=istat)
+ call check_allocate(istat, sub, 'press_ref')
ierr = pio_inq_varid(fh, 'press_ref', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': press_ref not found')
ierr = pio_get_var(fh, vid, press_ref)
@@ -1936,7 +1945,8 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading press_ref_trop')
! temperatures [K] for reference atmosphere; temp_ref(# reference layers)
- allocate(temp_ref(temperature))
+ allocate(temp_ref(temperature), stat=istat)
+ call check_allocate(istat, sub, 'temp_ref')
ierr = pio_inq_varid(fh, 'temp_ref', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': temp_ref not found')
ierr = pio_get_var(fh, vid, temp_ref)
@@ -1955,28 +1965,32 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading absorption_coefficient_ref_P')
! volume mixing ratios for reference atmosphere
- allocate(vmr_ref(atmos_layer, absorber_ext, temperature))
+ allocate(vmr_ref(atmos_layer, absorber_ext, temperature), stat=istat)
+ call check_allocate(istat, sub, 'vmr_ref')
ierr = pio_inq_varid(fh, 'vmr_ref', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': vmr_ref not found')
ierr = pio_get_var(fh, vid, vmr_ref)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading vmr_ref')
! absorption coefficients due to major absorbing gases
- allocate(kmajor(gpt,mixing_fraction,pressure_interp,temperature))
+ allocate(kmajor(gpt,mixing_fraction,pressure_interp,temperature), stat=istat)
+ call check_allocate(istat, sub, 'kmajor')
ierr = pio_inq_varid(fh, 'kmajor', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': kmajor not found')
ierr = pio_get_var(fh, vid, kmajor)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading kmajor')
! absorption coefficients due to minor absorbing gases in lower part of atmosphere
- allocate(kminor_lower(contributors_lower, mixing_fraction, temperature))
+ allocate(kminor_lower(contributors_lower, mixing_fraction, temperature), stat=istat)
+ call check_allocate(istat, sub, 'kminor_lower')
ierr = pio_inq_varid(fh, 'kminor_lower', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': kminor_lower not found')
ierr = pio_get_var(fh, vid, kminor_lower)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading kminor_lower')
! absorption coefficients due to minor absorbing gases in upper part of atmosphere
- allocate(kminor_upper(contributors_upper, mixing_fraction, temperature))
+ allocate(kminor_upper(contributors_upper, mixing_fraction, temperature), stat=istat)
+ call check_allocate(istat, sub, 'kminor_upper')
ierr = pio_inq_varid(fh, 'kminor_upper', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': kminor_upper not found')
ierr = pio_get_var(fh, vid, kminor_upper)
@@ -1985,7 +1999,8 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
! integrated Planck function by band
ierr = pio_inq_varid(fh, 'totplnk', vid)
if (ierr == PIO_NOERR) then
- allocate(totplnk(temperature_Planck,bnd))
+ allocate(totplnk(temperature_Planck,bnd), stat=istat)
+ call check_allocate(istat, sub, 'totplnk')
ierr = pio_get_var(fh, vid, totplnk)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading totplnk')
end if
@@ -1993,33 +2008,40 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
! Planck fractions
ierr = pio_inq_varid(fh, 'plank_fraction', vid)
if (ierr == PIO_NOERR) then
- allocate(planck_frac(gpt,mixing_fraction,pressure_interp,temperature))
+ allocate(planck_frac(gpt,mixing_fraction,pressure_interp,temperature), stat=istat)
+ call check_allocate(istat, sub, 'planck_frac')
ierr = pio_get_var(fh, vid, planck_frac)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading plank_fraction')
end if
ierr = pio_inq_varid(fh, 'optimal_angle_fit', vid)
if (ierr == PIO_NOERR) then
- allocate(optimal_angle_fit(fit_coeffs, bnd))
+ allocate(optimal_angle_fit(fit_coeffs, bnd), stat=istat)
+ call check_allocate(istat, sub, 'optiman_angle_fit')
ierr = pio_get_var(fh, vid, optimal_angle_fit)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading optimal_angle_fit')
end if
ierr = pio_inq_varid(fh, 'solar_source_quiet', vid)
if (ierr == PIO_NOERR) then
- allocate(solar_src_quiet(gpt))
+ allocate(solar_src_quiet(gpt), stat=istat)
+ call check_allocate(istat, sub, 'solar_src_quiet')
ierr = pio_get_var(fh, vid, solar_src_quiet)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading solar_source_quiet')
end if
+
ierr = pio_inq_varid(fh, 'solar_source_facular', vid)
if (ierr == PIO_NOERR) then
- allocate(solar_src_facular(gpt))
+ allocate(solar_src_facular(gpt), stat=istat)
+ call check_allocate(istat, sub, 'solar_src_facular')
ierr = pio_get_var(fh, vid, solar_src_facular)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading solar_source_facular')
end if
+
ierr = pio_inq_varid(fh, 'solar_source_sunspot', vid)
if (ierr == PIO_NOERR) then
- allocate(solar_src_sunspot(gpt))
+ allocate(solar_src_sunspot(gpt), stat=istat)
+ call check_allocate(istat, sub, 'solar_src_sunspot')
ierr = pio_get_var(fh, vid, solar_src_sunspot)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading solar_source_sunspot')
end if
@@ -2045,7 +2067,8 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
! rayleigh scattering contribution in lower part of atmosphere
ierr = pio_inq_varid(fh, 'rayl_lower', vid)
if (ierr == PIO_NOERR) then
- allocate(rayl_lower(gpt,mixing_fraction,temperature))
+ allocate(rayl_lower(gpt,mixing_fraction,temperature), stat=istat)
+ call check_allocate(istat, sub, 'rayl_lower')
ierr = pio_get_var(fh, vid, rayl_lower)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading rayl_lower')
end if
@@ -2053,50 +2076,59 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
! rayleigh scattering contribution in upper part of atmosphere
ierr = pio_inq_varid(fh, 'rayl_upper', vid)
if (ierr == PIO_NOERR) then
- allocate(rayl_upper(gpt,mixing_fraction,temperature))
+ allocate(rayl_upper(gpt,mixing_fraction,temperature), stat=istat)
+ call check_allocate(istat, sub, 'rayl_upper')
ierr = pio_get_var(fh, vid, rayl_upper)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading rayl_upper')
end if
- allocate(gas_minor(minorabsorbers))
+ allocate(gas_minor(minorabsorbers), stat=istat)
+ call check_allocate(istat, sub, 'gas_minor')
ierr = pio_inq_varid(fh, 'gas_minor', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': gas_minor not found')
ierr = pio_get_var(fh, vid, gas_minor)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading gas_minor')
- allocate(identifier_minor(minorabsorbers))
+ allocate(identifier_minor(minorabsorbers), stat=istat)
+ call check_allocate(istat, sub, 'identifier_minor')
ierr = pio_inq_varid(fh, 'identifier_minor', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': identifier_minor not found')
ierr = pio_get_var(fh, vid, identifier_minor)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading identifier_minor')
- allocate(minor_gases_lower(minor_absorber_intervals_lower))
+ allocate(minor_gases_lower(minor_absorber_intervals_lower), stat=istat)
+ call check_allocate(istat, sub, 'minor_gases_lower')
ierr = pio_inq_varid(fh, 'minor_gases_lower', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': minor_gases_lower not found')
ierr = pio_get_var(fh, vid, minor_gases_lower)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading minor_gases_lower')
- allocate(minor_gases_upper(minor_absorber_intervals_upper))
+ allocate(minor_gases_upper(minor_absorber_intervals_upper), stat=istat)
+ call check_allocate(istat, sub, 'minor_gases_upper')
ierr = pio_inq_varid(fh, 'minor_gases_upper', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': minor_gases_upper not found')
ierr = pio_get_var(fh, vid, minor_gases_upper)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading minor_gases_upper')
- allocate(minor_limits_gpt_lower(pairs,minor_absorber_intervals_lower))
+ allocate(minor_limits_gpt_lower(pairs,minor_absorber_intervals_lower), stat=istat)
+ call check_allocate(istat, sub, 'minor_limits_gpt_lower')
ierr = pio_inq_varid(fh, 'minor_limits_gpt_lower', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': minor_limits_gpt_lower not found')
ierr = pio_get_var(fh, vid, minor_limits_gpt_lower)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading minor_limits_gpt_lower')
- allocate(minor_limits_gpt_upper(pairs,minor_absorber_intervals_upper))
+ allocate(minor_limits_gpt_upper(pairs,minor_absorber_intervals_upper), stat=istat)
+ call check_allocate(istat, sub, 'minor_limits_gpt_upper')
ierr = pio_inq_varid(fh, 'minor_limits_gpt_upper', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': minor_limits_gpt_upper not found')
ierr = pio_get_var(fh, vid, minor_limits_gpt_upper)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading minor_limits_gpt_upper')
! Read as integer and convert to logical
- allocate(int2log(minor_absorber_intervals_lower))
- allocate(minor_scales_with_density_lower(minor_absorber_intervals_lower))
+ allocate(int2log(minor_absorber_intervals_lower), stat=istat)
+ call check_allocate(istat, sub, 'int2log for lower')
+ allocate(minor_scales_with_density_lower(minor_absorber_intervals_lower), stat=istat)
+ call check_allocate(istat, sub, 'minor_scales_with_density_lower')
ierr = pio_inq_varid(fh, 'minor_scales_with_density_lower', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': minor_scales_with_density_lower not found')
ierr = pio_get_var(fh, vid, int2log)
@@ -2111,8 +2143,10 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
deallocate(int2log)
! Read as integer and convert to logical
- allocate(int2log(minor_absorber_intervals_upper))
- allocate(minor_scales_with_density_upper(minor_absorber_intervals_upper))
+ allocate(int2log(minor_absorber_intervals_upper), stat=istat)
+ call check_allocate(istat, sub, 'int2log for upper')
+ allocate(minor_scales_with_density_upper(minor_absorber_intervals_upper), stat=istat)
+ call check_allocate(istat, sub, 'minor_scales_with_density_upper')
ierr = pio_inq_varid(fh, 'minor_scales_with_density_upper', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': minor_scales_with_density_upper not found')
ierr = pio_get_var(fh, vid, int2log)
@@ -2127,8 +2161,10 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
deallocate(int2log)
! Read as integer and convert to logical
- allocate(int2log(minor_absorber_intervals_lower))
- allocate(scale_by_complement_lower(minor_absorber_intervals_lower))
+ allocate(int2log(minor_absorber_intervals_lower), stat=istat)
+ call check_allocate(istat, sub, 'int2log for lower')
+ allocate(scale_by_complement_lower(minor_absorber_intervals_lower), stat=istat)
+ call check_allocate(istat, sub, 'scale_by_complement_lower')
ierr = pio_inq_varid(fh, 'scale_by_complement_lower', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': scale_by_complement_lower not found')
ierr = pio_get_var(fh, vid, int2log)
@@ -2143,8 +2179,10 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
deallocate(int2log)
! Read as integer and convert to logical
- allocate(int2log(minor_absorber_intervals_upper))
- allocate(scale_by_complement_upper(minor_absorber_intervals_upper))
+ allocate(int2log(minor_absorber_intervals_upper), stat=istat)
+ call check_allocate(istat, sub, 'int2log for upper')
+ allocate(scale_by_complement_upper(minor_absorber_intervals_upper), stat=istat)
+ call check_allocate(istat, sub, 'scale_by_complement_upper')
ierr = pio_inq_varid(fh, 'scale_by_complement_upper', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': scale_by_complement_upper not found')
ierr = pio_get_var(fh, vid, int2log)
@@ -2158,25 +2196,29 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
end do
deallocate(int2log)
- allocate(scaling_gas_lower(minor_absorber_intervals_lower))
+ allocate(scaling_gas_lower(minor_absorber_intervals_lower), stat=istat)
+ call check_allocate(istat, sub, 'scaling_gas_lower')
ierr = pio_inq_varid(fh, 'scaling_gas_lower', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': scaling_gas_lower not found')
ierr = pio_get_var(fh, vid, scaling_gas_lower)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading scaling_gas_lower')
- allocate(scaling_gas_upper(minor_absorber_intervals_upper))
+ allocate(scaling_gas_upper(minor_absorber_intervals_upper), stat=istat)
+ call check_allocate(istat, sub, 'scaling_gas_upper')
ierr = pio_inq_varid(fh, 'scaling_gas_upper', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': scaling_gas_upper not found')
ierr = pio_get_var(fh, vid, scaling_gas_upper)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading scaling_gas_upper')
- allocate(kminor_start_lower(minor_absorber_intervals_lower))
+ allocate(kminor_start_lower(minor_absorber_intervals_lower), stat=istat)
+ call check_allocate(istat, sub, 'kminor_start_lower')
ierr = pio_inq_varid(fh, 'kminor_start_lower', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': kminor_start_lower not found')
ierr = pio_get_var(fh, vid, kminor_start_lower)
if (ierr /= PIO_NOERR) call endrun(sub//': error reading kminor_start_lower')
- allocate(kminor_start_upper(minor_absorber_intervals_upper))
+ allocate(kminor_start_upper(minor_absorber_intervals_upper), stat=istat)
+ call check_allocate(istat, sub, 'kminor_start_upper')
ierr = pio_inq_varid(fh, 'kminor_start_upper', vid)
if (ierr /= PIO_NOERR) call endrun(sub//': kminor_start_upper not found')
ierr = pio_get_var(fh, vid, kminor_start_upper)
@@ -2238,23 +2280,23 @@ subroutine coefs_init(coefs_file, available_gases, kdist)
kmajor, kminor_lower, kminor_upper, &
gas_minor, identifier_minor, &
minor_gases_lower, minor_gases_upper, &
- scaling_gas_lower, scaling_gas_upper, &
minor_limits_gpt_lower, &
minor_limits_gpt_upper, &
minor_scales_with_density_lower, &
minor_scales_with_density_upper, &
scale_by_complement_lower, &
scale_by_complement_upper, &
+ scaling_gas_lower, scaling_gas_upper, &
kminor_start_lower, kminor_start_upper)
+ if (allocated(totplnk)) deallocate(totplnk)
+ if (allocated(planck_frac)) deallocate(planck_frac)
if (allocated(optimal_angle_fit)) deallocate(optimal_angle_fit)
- if (allocated(totplnk)) deallocate(totplnk)
- if (allocated(planck_frac)) deallocate(planck_frac)
if (allocated(solar_src_quiet)) deallocate(solar_src_quiet)
if (allocated(solar_src_facular)) deallocate(solar_src_facular)
if (allocated(solar_src_sunspot)) deallocate(solar_src_sunspot)
- if (allocated(rayl_lower)) deallocate(rayl_lower)
- if (allocated(rayl_upper)) deallocate(rayl_upper)
+ if (allocated(rayl_lower)) deallocate(rayl_lower)
+ if (allocated(rayl_upper)) deallocate(rayl_upper)
end subroutine coefs_init
@@ -2271,6 +2313,8 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct)
! Local variables
logical :: do_direct_local
+ integer :: istat
+ character(len=*), parameter :: sub = 'initialize_rrtmgp_fluxes'
!----------------------------------------------------------------------------
if (present(do_direct)) then
@@ -2280,16 +2324,28 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct)
end if
! Broadband fluxes
- allocate(fluxes%flux_up(ncol, nlevels))
- allocate(fluxes%flux_dn(ncol, nlevels))
- allocate(fluxes%flux_net(ncol, nlevels))
- if (do_direct_local) allocate(fluxes%flux_dn_dir(ncol, nlevels))
+ allocate(fluxes%flux_up(ncol, nlevels), stat=istat)
+ call check_allocate(istat, sub, 'fluxes%flux_up')
+ allocate(fluxes%flux_dn(ncol, nlevels), stat=istat)
+ call check_allocate(istat, sub, 'fluxes%flux_dn')
+ allocate(fluxes%flux_net(ncol, nlevels), stat=istat)
+ call check_allocate(istat, sub, 'fluxes%flux_net')
+ if (do_direct_local) then
+ allocate(fluxes%flux_dn_dir(ncol, nlevels), stat=istat)
+ call check_allocate(istat, sub, 'fluxes%flux_dn_dir')
+ end if
! Fluxes by band
- allocate(fluxes%bnd_flux_up(ncol, nlevels, nbands))
- allocate(fluxes%bnd_flux_dn(ncol, nlevels, nbands))
- allocate(fluxes%bnd_flux_net(ncol, nlevels, nbands))
- if (do_direct_local) allocate(fluxes%bnd_flux_dn_dir(ncol, nlevels, nbands))
+ allocate(fluxes%bnd_flux_up(ncol, nlevels, nbands), stat=istat)
+ call check_allocate(istat, sub, 'fluxes%bnd_flux_up')
+ allocate(fluxes%bnd_flux_dn(ncol, nlevels, nbands), stat=istat)
+ call check_allocate(istat, sub, 'fluxes%bnd_flux_dn')
+ allocate(fluxes%bnd_flux_net(ncol, nlevels, nbands), stat=istat)
+ call check_allocate(istat, sub, 'fluxes%bnd_flux_net')
+ if (do_direct_local) then
+ allocate(fluxes%bnd_flux_dn_dir(ncol, nlevels, nbands), stat=istat)
+ call check_allocate(istat, sub, 'fluxes%bnd_flux_dn_dir')
+ end if
! Initialize
call reset_fluxes(fluxes)
@@ -2423,5 +2479,21 @@ end subroutine stop_on_err
!=========================================================================================
+subroutine check_allocate(istat, sub, info)
+
+ ! call endrun if allocate returns non-zero status
+
+ integer, intent(in) :: istat ! return status from allocate
+ character(len=*), intent(in) :: sub ! name of calling subroutine
+ character(len=*), intent(in) :: info ! identify which call failed
+
+ if (istat /= 0) then
+ call endrun(trim(sub)//': ERROR allocating: '//trim(info))
+ end if
+
+end subroutine check_allocate
+
+!=========================================================================================
+
end module radiation