From 29da94d36769ec616148741650ca9a9d8a35b43b Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 13 Feb 2024 09:40:47 -0500 Subject: [PATCH] address review comments --- bld/configure | 2 +- src/physics/cam/aer_rad_props.F90 | 2 +- src/physics/cam/cloud_rad_props.F90 | 20 ++-- src/physics/cam/cospsimulator_intr.F90 | 4 +- src/physics/cam/ebert_curry_ice_optics.F90 | 2 +- src/physics/cam/slingo_liq_optics.F90 | 2 +- src/physics/camrt/radiation.F90 | 2 +- src/physics/camrt/radsw.F90 | 6 +- src/physics/rrtmg/aer_src/rrtmg_sw_reftra.f90 | 2 +- src/physics/rrtmg/radiation.F90 | 14 +-- src/physics/rrtmg/radsw.F90 | 2 +- src/physics/rrtmgp/mcica_subcol_gen.F90 | 20 ++-- src/physics/rrtmgp/radconstants.F90 | 4 +- src/physics/rrtmgp/radiation.F90 | 109 ++++++++---------- 14 files changed, 89 insertions(+), 102 deletions(-) diff --git a/bld/configure b/bld/configure index 7915dc75a5..974c30dc5e 100755 --- a/bld/configure +++ b/bld/configure @@ -1077,7 +1077,7 @@ if (defined $opts{'rad'}) { # the radiation package name in the config_cache file. if ($rad_pkg eq 'rrtmgp_gpu') { $use_rrtmgp_gpu = 1; - $rad_pkg =~ s!_gpu!! + $rad_pkg = 'rrtmgp'; } } diff --git a/src/physics/cam/aer_rad_props.F90 b/src/physics/cam/aer_rad_props.F90 index 9ee53bfae1..08dced5a93 100644 --- a/src/physics/cam/aer_rad_props.F90 +++ b/src/physics/cam/aer_rad_props.F90 @@ -130,7 +130,7 @@ subroutine aer_rad_props_sw(list_idx, state, pbuf, nnite, idxnite, & real(r8), intent(out) :: tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth real(r8), intent(out) :: tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8), intent(out) :: tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * tau * w + real(r8), intent(out) :: tau_w_g(pcols,0:pver,nswbands) ! aerosol asymmetry parameter * tau * w real(r8), intent(out) :: tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * tau * w ! Local variables diff --git a/src/physics/cam/cloud_rad_props.F90 b/src/physics/cam/cloud_rad_props.F90 index 9c8a1a3562..257138e7b5 100644 --- a/src/physics/cam/cloud_rad_props.F90 +++ b/src/physics/cam/cloud_rad_props.F90 @@ -71,6 +71,8 @@ module cloud_rad_props ixcldice, & ! cloud ice water index ixcldliq ! cloud liquid water index +real(r8), parameter :: tiny = 1.e-80_r8 + !============================================================================== contains !============================================================================== @@ -347,7 +349,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) ! asymetry parameter * tau * w + real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! asymmetry 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 +372,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) ! asymetry parameter * tau * w + real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! asymmetry parameter * tau * w real(r8),intent(out) :: tau_w_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w real(r8), pointer :: icswpth(:,:), des(:,:) @@ -393,7 +395,7 @@ 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) ! asymetry parameter * tau * w + real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! asymmetry parameter * tau * w real(r8),intent(out) :: tau_w_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w real(r8), pointer :: icgrauwpth(:,:), degrau(:,:) @@ -433,7 +435,7 @@ subroutine get_liquid_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) ! asymetry parameter * tau * w + real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! asymmetry parameter * tau * w real(r8),intent(out) :: tau_w_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w real(r8), pointer, dimension(:,:) :: lamc, pgam, iclwpth @@ -568,7 +570,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) ! asymetry parameter * tau * w + real(r8),intent(out) :: tau_w_g(nswbands,pcols,pver) ! asymmetry parameter * tau * w real(r8),intent(out) :: tau_w_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w type(interp_type) :: dei_wgts @@ -578,7 +580,7 @@ subroutine interpolate_ice_optics_sw(ncol, iciwpth, dei, tau, tau_w, & do k = 1,pver do i = 1,ncol - if( iciwpth(i,k) < 1.e-80_r8 .or. dei(i,k) == 0._r8) then + if( iciwpth(i,k) < tiny .or. dei(i,k) == 0._r8) then ! if ice water path is too small, OD := 0 tau (:,i,k) = 0._r8 tau_w (:,i,k) = 0._r8 @@ -626,7 +628,7 @@ subroutine interpolate_ice_optics_lw(ncol, iciwpth, dei, abs_od) do k = 1,pver do i = 1,ncol ! if ice water path is too small, OD := 0 - if( iciwpth(i,k) < 1.e-80_r8 .or. dei(i,k) == 0._r8) then + if( iciwpth(i,k) < tiny .or. dei(i,k) == 0._r8) then abs_od (:,i,k) = 0._r8 else ! for each cell interpolate to find weights in g_d_eff grid. @@ -659,7 +661,7 @@ subroutine gam_liquid_lw(clwptn, lamc, pgam, abs_od) type(interp_type) :: mu_wgts type(interp_type) :: lambda_wgts - if (clwptn < 1.e-80_r8) then + if (clwptn < tiny) then abs_od = 0._r8 return endif @@ -693,7 +695,7 @@ subroutine gam_liquid_sw(clwptn, lamc, pgam, tau, tau_w, tau_w_g, tau_w_f) type(interp_type) :: mu_wgts type(interp_type) :: lambda_wgts - if (clwptn < 1.e-80_r8) then + if (clwptn < tiny) then tau = 0._r8 tau_w = 0._r8 tau_w_g = 0._r8 diff --git a/src/physics/cam/cospsimulator_intr.F90 b/src/physics/cam/cospsimulator_intr.F90 index 855a8e82d5..6a01415f04 100644 --- a/src/physics/cam/cospsimulator_intr.F90 +++ b/src/physics/cam/cospsimulator_intr.F90 @@ -1107,7 +1107,7 @@ subroutine cospsimulator_intr_init() flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('MODIS_fracliq', (/'cosp_scol','lev '/), 'I','1', 'Fraction of tau from liquid water', & flag_xyfill=.true., fill_value=R_UNDEF) - call addfld ('MODIS_asym', (/'cosp_scol','lev '/), 'I','1', 'Assymetry parameter (MODIS)', & + call addfld ('MODIS_asym', (/'cosp_scol','lev '/), 'I','1', 'Asymmetry parameter (MODIS)', & flag_xyfill=.true., fill_value=R_UNDEF) call addfld ('MODIS_ssa', (/'cosp_scol','lev '/), 'I','1', 'Single-scattering albedo (MODIS)', & flag_xyfill=.true., fill_value=R_UNDEF) @@ -3262,7 +3262,7 @@ subroutine subsample_and_optics(nPoints, nLevels, nColumns, nHydro,overlap, MODIS_snowSize, cospIN%tau_067, MODIS_opticalThicknessLiq, & MODIS_opticalThicknessIce, MODIS_opticalThicknessSnow) - ! Compute assymetry parameter and single scattering albedo + ! Compute asymmetry parameter and single scattering albedo call modis_optics(nPoints, nLevels, nColumns, MODIS_opticalThicknessLiq, & MODIS_waterSize*1.0e6_wp, MODIS_opticalThicknessIce, & MODIS_iceSize*1.0e6_wp, MODIS_opticalThicknessSnow, & diff --git a/src/physics/cam/ebert_curry_ice_optics.F90 b/src/physics/cam/ebert_curry_ice_optics.F90 index 377d15de4a..8d9b4985a7 100644 --- a/src/physics/cam/ebert_curry_ice_optics.F90 +++ b/src/physics/cam/ebert_curry_ice_optics.F90 @@ -61,7 +61,7 @@ subroutine ec_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice real(r8),intent(out) :: ice_tau (nswbands,pcols,pver) ! extinction optical depth real(r8),intent(out) :: ice_tau_w (nswbands,pcols,pver) ! single scattering albedo * tau - real(r8),intent(out) :: ice_tau_w_g(nswbands,pcols,pver) ! assymetry parameter * tau * w + real(r8),intent(out) :: ice_tau_w_g(nswbands,pcols,pver) ! asymmetry parameter * tau * w real(r8),intent(out) :: ice_tau_w_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w logical, intent(in) :: oldicewp diff --git a/src/physics/cam/slingo_liq_optics.F90 b/src/physics/cam/slingo_liq_optics.F90 index 28b97920e8..781a056b29 100644 --- a/src/physics/cam/slingo_liq_optics.F90 +++ b/src/physics/cam/slingo_liq_optics.F90 @@ -82,7 +82,7 @@ subroutine slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, li real(r8),intent(out) :: liq_tau (nswbands,pcols,pver) ! extinction optical depth real(r8),intent(out) :: liq_tau_w (nswbands,pcols,pver) ! single scattering albedo * tau - real(r8),intent(out) :: liq_tau_w_g(nswbands,pcols,pver) ! assymetry parameter * tau * w + real(r8),intent(out) :: liq_tau_w_g(nswbands,pcols,pver) ! asymmetry parameter * tau * w real(r8),intent(out) :: liq_tau_w_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w logical, intent(in) :: oldliqwp diff --git a/src/physics/camrt/radiation.F90 b/src/physics/camrt/radiation.F90 index 7cd74faa11..7ca7b15daa 100644 --- a/src/physics/camrt/radiation.F90 +++ b/src/physics/camrt/radiation.F90 @@ -877,7 +877,7 @@ subroutine radiation_tend( & ! Aerosol shortwave radiative properties real(r8) :: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol asymmetry parameter * w * tau real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau ! Aerosol longwave absorption optical depth diff --git a/src/physics/camrt/radsw.F90 b/src/physics/camrt/radsw.F90 index e0d609a4cc..58138e4a5f 100644 --- a/src/physics/camrt/radsw.F90 +++ b/src/physics/camrt/radsw.F90 @@ -237,7 +237,7 @@ subroutine radcswmx(lchnk ,ncol , & ! real(r8),intent(in) :: E_aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth real(r8),intent(in) :: E_aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8),intent(in) :: E_aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8),intent(in) :: E_aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol asymmetry parameter * w * tau real(r8),intent(in) :: E_aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau ! @@ -288,7 +288,7 @@ subroutine radcswmx(lchnk ,ncol , & ! real(r8):: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth real(r8):: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8):: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8):: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol asymmetry parameter * w * tau real(r8):: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau real(r8) :: pmid(pcols,pver) ! Level pressure real(r8) :: pint(pcols,pverp) ! Interface pressure @@ -1994,7 +1994,7 @@ subroutine raddedmx(coszrs ,ndayc ,abh2o , & ! real(r8) trmin ! Minimum total transmission allowed real(r8) wray ! Rayleigh single scatter albedo - real(r8) gray ! Rayleigh asymetry parameter + real(r8) gray ! Rayleigh asymmetry parameter real(r8) fray ! Rayleigh forward scattered fraction parameter (trmin = 1.e-3_r8) diff --git a/src/physics/rrtmg/aer_src/rrtmg_sw_reftra.f90 b/src/physics/rrtmg/aer_src/rrtmg_sw_reftra.f90 index d37f392025..1622e48450 100644 --- a/src/physics/rrtmg/aer_src/rrtmg_sw_reftra.f90 +++ b/src/physics/rrtmg/aer_src/rrtmg_sw_reftra.f90 @@ -43,7 +43,7 @@ subroutine reftra_sw(nlayers, ncol, lrtchk, pgg, prmuz, ptau, pw, & ! lrtchk = .t. for all layers in clear profile ! lrtchk = .t. for cloudy layers in cloud profile ! = .f. for clear layers in cloud profile -! pgg = assymetry factor +! pgg = asymmetry factor ! prmuz = cosine solar zenith angle ! ptau = optical thickness ! pw = single scattering albedo diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index 3b47e8c2ad..12f8cd7ec6 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -806,28 +806,28 @@ subroutine radiation_tend( & ! cloud radiative parameters are "in cloud" not "in cell" real(r8) :: ice_tau (nswbands,pcols,pver) ! ice extinction optical depth real(r8) :: ice_tau_w (nswbands,pcols,pver) ! ice single scattering albedo * tau - real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! ice assymetry parameter * tau * w + real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! ice asymmetry parameter * tau * w real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! ice forward scattered fraction * tau * w real(r8) :: ice_lw_abs (nlwbands,pcols,pver) ! ice absorption optics depth (LW) ! cloud radiative parameters are "in cloud" not "in cell" real(r8) :: liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth real(r8) :: liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau - real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w + real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! liquid asymmetry parameter * tau * w real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w real(r8) :: liq_lw_abs (nlwbands,pcols,pver) ! liquid absorption optics depth (LW) ! cloud radiative parameters are "in cloud" not "in cell" real(r8) :: cld_tau (nswbands,pcols,pver) ! cloud extinction optical depth real(r8) :: cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau - real(r8) :: cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau + real(r8) :: cld_tau_w_g(nswbands,pcols,pver) ! cloud asymmetry parameter * w * tau real(r8) :: cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) ! cloud radiative parameters are "in cloud" not "in cell" real(r8) :: snow_tau (nswbands,pcols,pver) ! snow extinction optical depth real(r8) :: snow_tau_w (nswbands,pcols,pver) ! snow single scattering albedo * tau - real(r8) :: snow_tau_w_g(nswbands,pcols,pver) ! snow assymetry parameter * tau * w + real(r8) :: snow_tau_w_g(nswbands,pcols,pver) ! snow asymmetry parameter * tau * w real(r8) :: snow_tau_w_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) @@ -835,7 +835,7 @@ subroutine radiation_tend( & ! cloud radiative parameters are "in cloud" not "in cell" real(r8) :: grau_tau (nswbands,pcols,pver) ! graupel extinction optical depth real(r8) :: grau_tau_w (nswbands,pcols,pver) ! graupel single scattering albedo * tau - real(r8) :: grau_tau_w_g(nswbands,pcols,pver) ! graupel assymetry parameter * tau * w + real(r8) :: grau_tau_w_g(nswbands,pcols,pver) ! graupel asymmetry parameter * tau * w real(r8) :: grau_tau_w_f(nswbands,pcols,pver) ! graupel forward scattered fraction * tau * w real(r8) :: grau_lw_abs (nlwbands,pcols,pver)! graupel absorption optics depth (LW) @@ -843,7 +843,7 @@ subroutine radiation_tend( & real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction (snow plus regular) real(r8) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth real(r8) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau - real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau + real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud asymmetry parameter * w * tau real(r8) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) @@ -855,7 +855,7 @@ subroutine radiation_tend( & ! Aerosol radiative properties real(r8) :: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol asymmetry parameter * w * tau real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) diff --git a/src/physics/rrtmg/radsw.F90 b/src/physics/rrtmg/radsw.F90 index df222557dd..994d56b44e 100644 --- a/src/physics/rrtmg/radsw.F90 +++ b/src/physics/rrtmg/radsw.F90 @@ -255,7 +255,7 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & ! Aerosol radiative property arrays real(r8) :: tauxar(pcols,0:pver) ! aerosol extinction optical depth real(r8) :: wa(pcols,0:pver) ! aerosol single scattering albedo - real(r8) :: ga(pcols,0:pver) ! aerosol assymetry parameter + real(r8) :: ga(pcols,0:pver) ! aerosol asymmetry parameter real(r8) :: fa(pcols,0:pver) ! aerosol forward scattered fraction ! CRM diff --git a/src/physics/rrtmgp/mcica_subcol_gen.F90 b/src/physics/rrtmgp/mcica_subcol_gen.F90 index ccd414fd5f..85bea8281c 100644 --- a/src/physics/rrtmgp/mcica_subcol_gen.F90 +++ b/src/physics/rrtmgp/mcica_subcol_gen.F90 @@ -1,5 +1,14 @@ module mcica_subcol_gen +!---------------------------------------------------------------------------------------- +! +! Purpose: Create McICA stochastic arrays for cloud optical properties. +! Input cloud optical properties directly: cloud optical depth, single +! scattering albedo and asymmetry parameter. Output will be stochastic +! arrays of these variables. (longwave scattering is not yet available) +! +! Original code: From RRTMG, with the following copyright notice, +! based on Raisanen et al., QJRMS, 2004: ! -------------------------------------------------------------------------- ! | | ! | Copyright 2006-2007, Atmospheric & Environmental Research, Inc. (AER). | @@ -9,15 +18,8 @@ module mcica_subcol_gen ! | (http://www.rtweb.aer.com/) | ! | | ! -------------------------------------------------------------------------- - -!---------------------------------------------------------------------------------------- -! -! Purpose: Create McICA stochastic arrays for cloud optical properties. -! Input cloud optical properties directly: cloud optical depth, single -! scattering albedo and asymmetry parameter. Output will be stochastic -! arrays of these variables. (longwave scattering is not yet available) -! -! Original code: From RRTMG based on Raisanen et al., QJRMS, 2004. +! This code is a refactored version of code originally in the files +! mcica_subcol_gen_lw.F90 and mcica_subcol_gen_sw.F90 ! ! Uses the KISS random number generator. ! diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index 06dccde2b8..f490b81b7b 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -13,8 +13,8 @@ module radconstants ! Number of bands in SW and LW. These values must match data in the RRTMGP coefficients datasets. ! But they are needed to allocate space in the physics buffer and need to be available before the -! RRTMGP datasets are read. So they are set as parameters here and checked in radiation_init after -! the datasets are read. +! RRTMGP datasets are read. So they are set as parameters here and checked in the +! set_wavenumber_bands subroutine after the datasets are read. integer, parameter, public :: nswbands = 14 integer, parameter, public :: nlwbands = 16 diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 099eaeae3c..18488bedb7 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -56,8 +56,7 @@ module radiation use mo_fluxes_byband, only: ty_fluxes_byband use string_utils, only: to_lower -use cam_abortutils, only: endrun -use error_messages, only: handle_err +use cam_abortutils, only: endrun, handle_allocate_error use cam_logfile, only: iulog @@ -531,7 +530,7 @@ subroutine radiation_init(pbuf2d) if (docosp) call cospsimulator_intr_init() allocate(cosp_cnt(begchunk:endchunk), stat=istat) - call check_allocate(istat, sub, 'cosp_cnt') + call handle_allocate_error(istat, sub, 'cosp_cnt') if (is_first_restart_step()) then cosp_cnt(begchunk:endchunk) = cosp_cnt_init else @@ -989,7 +988,7 @@ subroutine radiation_tend( & write_output = .false. else allocate(rd, stat=istat) - call check_allocate(istat, sub, 'rd') + call handle_allocate_error(istat, sub, 'rd') write_output = .true. end if @@ -1089,7 +1088,7 @@ subroutine radiation_tend( & 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') + call handle_allocate_error(istat, sub, 't_sfc,..,alb_dif') ! Prepares state variables, daylit columns, albedos for RRTMGP call rrtmgp_set_state( & @@ -1904,7 +1903,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! names of absorbing gases allocate(gas_names(absorber), stat=istat) - call check_allocate(istat, sub, 'gas_names') + call handle_allocate_error(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) @@ -1912,7 +1911,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! key species pair for each band allocate(key_species(2,atmos_layer,bnd), stat=istat) - call check_allocate(istat, sub, 'key_species') + call handle_allocate_error(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) @@ -1920,7 +1919,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! beginning and ending gpoint for each band allocate(band2gpt(2,bnd), stat=istat) - call check_allocate(istat, sub, 'band2gpt') + call handle_allocate_error(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) @@ -1928,7 +1927,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! beginning and ending wavenumber for each band allocate(band_lims_wavenum(2,bnd), stat=istat) - call check_allocate(istat, sub, 'band_lims_wavenum') + call handle_allocate_error(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) @@ -1936,7 +1935,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! pressures [hPa] for reference atmosphere; press_ref(# reference layers) allocate(press_ref(pressure), stat=istat) - call check_allocate(istat, sub, 'press_ref') + call handle_allocate_error(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) @@ -1950,7 +1949,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! temperatures [K] for reference atmosphere; temp_ref(# reference layers) allocate(temp_ref(temperature), stat=istat) - call check_allocate(istat, sub, 'temp_ref') + call handle_allocate_error(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) @@ -1970,7 +1969,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! volume mixing ratios for reference atmosphere allocate(vmr_ref(atmos_layer, absorber_ext, temperature), stat=istat) - call check_allocate(istat, sub, 'vmr_ref') + call handle_allocate_error(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) @@ -1978,7 +1977,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! absorption coefficients due to major absorbing gases allocate(kmajor(gpt,mixing_fraction,pressure_interp,temperature), stat=istat) - call check_allocate(istat, sub, 'kmajor') + call handle_allocate_error(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) @@ -1986,7 +1985,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! absorption coefficients due to minor absorbing gases in lower part of atmosphere allocate(kminor_lower(contributors_lower, mixing_fraction, temperature), stat=istat) - call check_allocate(istat, sub, 'kminor_lower') + call handle_allocate_error(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) @@ -1994,7 +1993,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! absorption coefficients due to minor absorbing gases in upper part of atmosphere allocate(kminor_upper(contributors_upper, mixing_fraction, temperature), stat=istat) - call check_allocate(istat, sub, 'kminor_upper') + call handle_allocate_error(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) @@ -2004,7 +2003,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_inq_varid(fh, 'totplnk', vid) if (ierr == PIO_NOERR) then allocate(totplnk(temperature_Planck,bnd), stat=istat) - call check_allocate(istat, sub, 'totplnk') + call handle_allocate_error(istat, sub, 'totplnk') ierr = pio_get_var(fh, vid, totplnk) if (ierr /= PIO_NOERR) call endrun(sub//': error reading totplnk') end if @@ -2013,7 +2012,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_inq_varid(fh, 'plank_fraction', vid) if (ierr == PIO_NOERR) then allocate(planck_frac(gpt,mixing_fraction,pressure_interp,temperature), stat=istat) - call check_allocate(istat, sub, 'planck_frac') + call handle_allocate_error(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 @@ -2021,7 +2020,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_inq_varid(fh, 'optimal_angle_fit', vid) if (ierr == PIO_NOERR) then allocate(optimal_angle_fit(fit_coeffs, bnd), stat=istat) - call check_allocate(istat, sub, 'optiman_angle_fit') + call handle_allocate_error(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 @@ -2029,7 +2028,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_inq_varid(fh, 'solar_source_quiet', vid) if (ierr == PIO_NOERR) then allocate(solar_src_quiet(gpt), stat=istat) - call check_allocate(istat, sub, 'solar_src_quiet') + call handle_allocate_error(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 @@ -2037,7 +2036,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_inq_varid(fh, 'solar_source_facular', vid) if (ierr == PIO_NOERR) then allocate(solar_src_facular(gpt), stat=istat) - call check_allocate(istat, sub, 'solar_src_facular') + call handle_allocate_error(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 @@ -2045,7 +2044,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_inq_varid(fh, 'solar_source_sunspot', vid) if (ierr == PIO_NOERR) then allocate(solar_src_sunspot(gpt), stat=istat) - call check_allocate(istat, sub, 'solar_src_sunspot') + call handle_allocate_error(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 @@ -2072,7 +2071,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_inq_varid(fh, 'rayl_lower', vid) if (ierr == PIO_NOERR) then allocate(rayl_lower(gpt,mixing_fraction,temperature), stat=istat) - call check_allocate(istat, sub, 'rayl_lower') + call handle_allocate_error(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 @@ -2081,48 +2080,48 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_inq_varid(fh, 'rayl_upper', vid) if (ierr == PIO_NOERR) then allocate(rayl_upper(gpt,mixing_fraction,temperature), stat=istat) - call check_allocate(istat, sub, 'rayl_upper') + call handle_allocate_error(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), stat=istat) - call check_allocate(istat, sub, 'gas_minor') + call handle_allocate_error(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), stat=istat) - call check_allocate(istat, sub, 'identifier_minor') + call handle_allocate_error(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), stat=istat) - call check_allocate(istat, sub, 'minor_gases_lower') + call handle_allocate_error(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), stat=istat) - call check_allocate(istat, sub, 'minor_gases_upper') + call handle_allocate_error(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), stat=istat) - call check_allocate(istat, sub, 'minor_limits_gpt_lower') + call handle_allocate_error(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), stat=istat) - call check_allocate(istat, sub, 'minor_limits_gpt_upper') + call handle_allocate_error(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) @@ -2130,10 +2129,10 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! Read as integer and convert to logical allocate(int2log(minor_absorber_intervals_lower), stat=istat) - call check_allocate(istat, sub, 'int2log for lower') + call handle_allocate_error(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') + call handle_allocate_error(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) @@ -2147,7 +2146,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) end do allocate(scale_by_complement_lower(minor_absorber_intervals_lower), stat=istat) - call check_allocate(istat, sub, 'scale_by_complement_lower') + call handle_allocate_error(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) @@ -2164,10 +2163,10 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! Read as integer and convert to logical allocate(int2log(minor_absorber_intervals_upper), stat=istat) - call check_allocate(istat, sub, 'int2log for upper') + call handle_allocate_error(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') + call handle_allocate_error(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) @@ -2181,7 +2180,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) end do allocate(scale_by_complement_upper(minor_absorber_intervals_upper), stat=istat) - call check_allocate(istat, sub, 'scale_by_complement_upper') + call handle_allocate_error(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) @@ -2197,28 +2196,28 @@ subroutine coefs_init(coefs_file, available_gases, kdist) deallocate(int2log) allocate(scaling_gas_lower(minor_absorber_intervals_lower), stat=istat) - call check_allocate(istat, sub, 'scaling_gas_lower') + call handle_allocate_error(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), stat=istat) - call check_allocate(istat, sub, 'scaling_gas_upper') + call handle_allocate_error(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), stat=istat) - call check_allocate(istat, sub, 'kminor_start_lower') + call handle_allocate_error(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), stat=istat) - call check_allocate(istat, sub, 'kminor_start_upper') + call handle_allocate_error(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) @@ -2325,14 +2324,14 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct) ! Broadband fluxes allocate(fluxes%flux_up(ncol, nlevels), stat=istat) - call check_allocate(istat, sub, 'fluxes%flux_up') + call handle_allocate_error(istat, sub, 'fluxes%flux_up') allocate(fluxes%flux_dn(ncol, nlevels), stat=istat) - call check_allocate(istat, sub, 'fluxes%flux_dn') + call handle_allocate_error(istat, sub, 'fluxes%flux_dn') allocate(fluxes%flux_net(ncol, nlevels), stat=istat) - call check_allocate(istat, sub, 'fluxes%flux_net') + call handle_allocate_error(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') + call handle_allocate_error(istat, sub, 'fluxes%flux_dn_dir') end if select type (fluxes) @@ -2341,14 +2340,14 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct) ! when spectralflux is true. if (nbands == nswbands .or. spectralflux) then allocate(fluxes%bnd_flux_up(ncol, nlevels, nbands), stat=istat) - call check_allocate(istat, sub, 'fluxes%bnd_flux_up') + call handle_allocate_error(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') + call handle_allocate_error(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') + call handle_allocate_error(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') + call handle_allocate_error(istat, sub, 'fluxes%bnd_flux_dn_dir') end if end if end select @@ -2488,21 +2487,5 @@ 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