From 1eccc4920f8dc67b27ba4f7693dd025bdc978f67 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 5 May 2023 12:59:20 -0400 Subject: [PATCH 01/53] merge rrtmgp code from brianpm fork --- Externals_CAM.cfg | 7 + bld/build-namelist | 31 +- bld/config_files/definition.xml | 4 +- bld/configure | 12 +- bld/namelist_files/namelist_defaults_cam.xml | 72 + bld/namelist_files/namelist_definition.xml | 21 +- .../usermods_dirs/rrtmgp/shell_commands | 7 + cime_config/usermods_dirs/rrtmgp/user_nl_cam | 11 + .../usermods_dirs/scam_rrtmgp/shell_commands | 21 + .../usermods_dirs/scam_rrtmgp/user_nl_cam | 15 + src/physics/cam/modal_aer_opt.F90 | 16 +- src/physics/rrtmg/radiation.F90 | 6 + src/physics/rrtmgp/b_checker.f90 | 163 + src/physics/rrtmgp/cloud_rad_props.F90 | 840 +++++ src/physics/rrtmgp/ebert_curry.F90 | 408 +++ src/physics/rrtmgp/mcica_subcol_gen.F90 | 293 ++ src/physics/rrtmgp/oldcloud.F90 | 643 ++++ src/physics/rrtmgp/rad_solar_var.F90 | 148 + src/physics/rrtmgp/radconstants.F90 | 427 +++ src/physics/rrtmgp/radiation.F90 | 3070 +++++++++++++++++ src/physics/rrtmgp/rrtmgp_driver.F90 | 386 +++ src/physics/rrtmgp/rrtmgp_inputs.F90 | 838 +++++ src/physics/rrtmgp/slingo.F90 | 409 +++ 23 files changed, 7832 insertions(+), 16 deletions(-) create mode 100755 cime_config/usermods_dirs/rrtmgp/shell_commands create mode 100644 cime_config/usermods_dirs/rrtmgp/user_nl_cam create mode 100755 cime_config/usermods_dirs/scam_rrtmgp/shell_commands create mode 100644 cime_config/usermods_dirs/scam_rrtmgp/user_nl_cam create mode 100644 src/physics/rrtmgp/b_checker.f90 create mode 100644 src/physics/rrtmgp/cloud_rad_props.F90 create mode 100644 src/physics/rrtmgp/ebert_curry.F90 create mode 100644 src/physics/rrtmgp/mcica_subcol_gen.F90 create mode 100644 src/physics/rrtmgp/oldcloud.F90 create mode 100644 src/physics/rrtmgp/rad_solar_var.F90 create mode 100644 src/physics/rrtmgp/radconstants.F90 create mode 100644 src/physics/rrtmgp/radiation.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_driver.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_inputs.F90 create mode 100644 src/physics/rrtmgp/slingo.F90 diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index caba5270c2..a87d3b1719 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -1,3 +1,10 @@ +[rrtmgp] +local_path = src/physics/rrtmgp/ext +protocol = git +repo_url = https://github.com/earth-system-radiation/rte-rrtmgp.git +tag = v1.6 +required = True + [chem_proc] local_path = chem_proc protocol = git diff --git a/bld/build-namelist b/bld/build-namelist index 2cec1b4a51..fe4e4af791 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -670,6 +670,22 @@ my $rad_pkg = $cfg->get('rad'); if ($rad_pkg eq 'camrt') { add_default($nl, 'absems_data'); } +elsif ($rad_pkg eq 'rrtmgp') { + # Data for gas optics is provided with the source code. The paths to this data + # are relative to the root directory of the cam component. + my $cam_dir = $cfg->get('cam_dir'); + + add_default($nl, 'rrtmgp_coefs_lw_file'); + my $rel_path = $nl->get_value('rrtmgp_coefs_lw_file'); + my $abs_path = quote_string(set_abs_filepath($rel_path, $cam_dir)); + # need to overwrite the relative pathname with the absolute pathname in the namelist object + $nl->set_variable_value('radiation_nl', 'rrtmgp_coefs_lw_file', $abs_path); + + add_default($nl, 'rrtmgp_coefs_sw_file'); + $rel_path = $nl->get_value('rrtmgp_coefs_sw_file'); + my $abs_path = quote_string(set_abs_filepath($rel_path, $cam_dir)); + $nl->set_variable_value('radiation_nl', 'rrtmgp_coefs_sw_file', $abs_path); +} # Solar irradiance @@ -681,15 +697,18 @@ if (defined $nl->get_value('solar_const') and } -if ($rad_pkg eq 'rrtmg' or $chem =~ /waccm/) { +if ($rad_pkg =~ /rrtmg/ or $chem =~ /waccm/) { if (defined $nl->get_value('solar_const')) { - die "$ProgName - ERROR: Specifying solar_const with RRTMG or WACCM is not allowed.\n" + die "$ProgName - ERROR: Specifying solar_const with RRTMG/RRTMGP or WACCM is not allowed.\n" } # use solar data file as the default for rrtmg and waccm_ma add_default($nl, 'solar_irrad_data_file'); - add_default($nl, 'solar_htng_spctrl_scl', 'val'=>'.true.'); + # restrict this option to just the rrtmg code + if ($rad_pkg eq 'rrtmg') { + add_default($nl, 'solar_htng_spctrl_scl', 'val'=>'.true.'); + } } elsif (!$simple_phys) { @@ -1095,7 +1114,7 @@ if ($aer_model eq 'mam' ) { } if ($rad_prog_sslt) { - if ($rrtmg) { + if ($rad_pkg =~ /rrtmg/) { push(@aero_names, "SSLT01", "SSLT02", "SSLT03", "SSLT04"); push(@aerosources, "A:", "A:", "A:", "A:" ); } else { @@ -1103,7 +1122,7 @@ if ($aer_model eq 'mam' ) { push(@aerosources, "N:", "N:"); } } elsif ($moz_aero_data =~ /$TRUE/io ) { - if ($rrtmg) { + if ($rad_pkg =~ /rrtmg/) { push(@aero_names, "sslt1", "sslt2", "sslt3", "sslt4"); push(@aerosources, "N:", "N:", "N:", "N:" ); } else { @@ -1618,7 +1637,7 @@ if ($rad_pkg ne 'none') { } # Cloud optics -if ($rrtmg) { +if ($rad_pkg =~ /rrtmg/) { # matches both rrtmg and rrtmgp add_default($nl, 'liqcldoptics'); add_default($nl, 'icecldoptics'); add_default($nl, 'liqopticsfile'); diff --git a/bld/config_files/definition.xml b/bld/config_files/definition.xml index 095bf87d97..1cac857da4 100644 --- a/bld/config_files/definition.xml +++ b/bld/config_files/definition.xml @@ -83,9 +83,9 @@ on Mapes and Neale (2011): 0 => no, 1 => yes PBL package: uw (University of Washington), hb (Holtslag and Boville), hbr (Holtslag, Boville, and Rasch), clubb_sgs, spcam_sam1om, spcam_m2005, none. - + Radiative transfer calculation: -camrt (CAM3 and CAM4 RT package), rrtmg (RRTMG package from AER). +camrt (CAM3 and CAM4 RT package), rrtmg (RRTMG package from AER), rrtmgp (updated version). CARMA sectional microphysics: diff --git a/bld/configure b/bld/configure index 3bb8f8958b..1bfb2b3983 100755 --- a/bld/configure +++ b/bld/configure @@ -102,7 +102,7 @@ OPTIONS -prog_species Comma-separate list of prognostic mozart species packages. Currently available: DST,SSLT,SO4,GHG,OC,BC,CARBON16 -psubcols Maximum number of sub-columns in a run - set to 1 if not using sub-columns (default) - -rad Specify the radiation package [rrtmg | camrt] + -rad Specify the radiation package [rrtmg | rrtmgp | camrt] -silhs Switch on SILHS. -spcam_clubb_sgs Turn on the SPCAM version of CLUBB -spcam_nx SPCAM x-grid. - defaults to 4 (note the CRM requires spcam_nx to be greater than or equal to 4) @@ -2162,6 +2162,16 @@ sub write_filepath elsif ($rad eq 'camrt') { print $fh "$camsrcdir/src/physics/camrt\n"; } + elsif ($rad eq 'rrtmgp') { + print $fh "$camsrcdir/src/physics/rrtmgp\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte/kernels\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp/kernels\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/extensions\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/extensions/cloud_optics\n"; + } if ($clubb_sgs) { print $fh "$camsrcdir/src/physics/clubb\n"; diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 3444771dae..a765e0ea59 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -426,6 +426,36 @@ atm/cam/physprops/ssam_rrtmg_c080918.nc atm/cam/physprops/sscm_rrtmg_c080918.nc + +atm/cam/physprops/sulfate_rrtmg_c080918.nc +atm/cam/physprops/sulfate_rrtmg_c080918.nc +atm/cam/physprops/dust1_rrtmg_c080918.nc +atm/cam/physprops/dust1_rrtmg_c080918.nc +atm/cam/physprops/dust2_rrtmg_c080918.nc +atm/cam/physprops/dust2_rrtmg_c080918.nc +atm/cam/physprops/dust3_rrtmg_c080918.nc +atm/cam/physprops/dust3_rrtmg_c080918.nc +atm/cam/physprops/dust4_rrtmg_c080918.nc +atm/cam/physprops/dust4_rrtmg_c080918.nc +atm/cam/physprops/bcpho_rrtmg_c080918.nc +atm/cam/physprops/bcpho_rrtmg_c080918.nc +atm/cam/physprops/bcphi_rrtmg_c080918.nc +atm/cam/physprops/bcphi_rrtmg_c080918.nc +atm/cam/physprops/ocpho_rrtmg_c080918.nc +atm/cam/physprops/ocpho_rrtmg_c080918.nc +atm/cam/physprops/ocphi_rrtmg_c080918.nc +atm/cam/physprops/ocphi_rrtmg_c080918.nc +atm/cam/physprops/seasalt1_rrtmg_c080918.nc +atm/cam/physprops/seasalt1_rrtmg_c080918.nc +atm/cam/physprops/seasalt2_rrtmg_c080918.nc +atm/cam/physprops/seasalt2_rrtmg_c080918.nc +atm/cam/physprops/seasalt3_rrtmg_c080918.nc +atm/cam/physprops/seasalt3_rrtmg_c080918.nc +atm/cam/physprops/seasalt4_rrtmg_c080918.nc +atm/cam/physprops/seasalt4_rrtmg_c080918.nc +atm/cam/physprops/ssam_rrtmg_c080918.nc +atm/cam/physprops/sscm_rrtmg_c080918.nc + @@ -437,6 +467,15 @@ atm/cam/physprops/ssam_rrtmg_c100508.nc atm/cam/physprops/dust_aeronet_rrtmg_c141106.nc atm/cam/physprops/sulfate_rrtmg_c080918.nc + +atm/cam/physprops/sulfate_rrtmg_c080918.nc +atm/cam/physprops/ocpho_rrtmg_c101112.nc +atm/cam/physprops/ocpho_rrtmg_c130709.nc +atm/cam/physprops/ocphi_rrtmg_c100508.nc +atm/cam/physprops/bcpho_rrtmg_c100508.nc +atm/cam/physprops/ssam_rrtmg_c100508.nc +atm/cam/physprops/dust_aeronet_rrtmg_c141106.nc +atm/cam/physprops/sulfate_rrtmg_c080918.nc atm/cam/physprops/volc_camRT_byradius_sigma1.6_c130724.nc @@ -445,6 +484,11 @@ atm/cam/physprops/volc_camRRTMG_byradius_sigma1.6_mode1_c210211.nc atm/cam/physprops/volc_camRRTMG_byradius_sigma1.6_mode2_c210211.nc atm/cam/physprops/volc_camRRTMG_byradius_sigma1.2_mode3_c210211.nc + +atm/cam/physprops/volc_camRRTMG_byradius_sigma1.6_c130724.nc +atm/cam/physprops/volc_camRRTMG_byradius_sigma1.6_mode1_c210211.nc +atm/cam/physprops/volc_camRRTMG_byradius_sigma1.6_mode2_c210211.nc +atm/cam/physprops/volc_camRRTMG_byradius_sigma1.2_mode3_c210211.nc atm/cam/physprops/mam4_mode1_rrtmg_aeronetdust_c141106.nc @@ -475,6 +519,25 @@ atm/cam/physprops/mam7_mode5_rrtmg_c120904.nc atm/cam/physprops/mam7_mode6_rrtmg_c120904.nc atm/cam/physprops/mam7_mode7_rrtmg_c120904.nc + +atm/cam/physprops/mam4_mode1_rrtmg_aeronetdust_c141106.nc +atm/cam/physprops/mam4_mode2_rrtmg_aitkendust_c141106.nc +atm/cam/physprops/mam4_mode3_rrtmg_aeronetdust_c141106.nc +atm/cam/physprops/mam4_mode1_rrtmg_aeronetdust_sig1.6_dgnh.48_c140304.nc +atm/cam/physprops/mam4_mode3_rrtmg_aeronetdust_sig1.2_dgnl.40_c150219.nc +atm/cam/physprops/mam4_mode1_rrtmg_aeronetdust_c141106.nc +atm/cam/physprops/mam4_mode2_rrtmg_aitkendust_c141106.nc +atm/cam/physprops/mam4_mode3_rrtmg_aeronetdust_c141106.nc +atm/cam/physprops/mam4_mode4_rrtmg_c130628.nc +atm/cam/physprops/mam4_mode1_rrtmg_aeronetdust_sig1.6_dgnh.48_c140304.nc +atm/cam/physprops/mam4_mode3_rrtmg_aeronetdust_sig1.2_dgnl.40_c150219.nc +atm/cam/physprops/mam7_mode1_rrtmg_c120904.nc +atm/cam/physprops/mam7_mode2_rrtmg_c120904.nc +atm/cam/physprops/mam7_mode3_rrtmg_c120904.nc +atm/cam/physprops/mam7_mode4_rrtmg_c120904.nc +atm/cam/physprops/mam7_mode5_rrtmg_c120904.nc +atm/cam/physprops/mam7_mode6_rrtmg_c120904.nc +atm/cam/physprops/mam7_mode7_rrtmg_c120904.nc atm/cam/physprops/water_refindex_rrtmg_c080910.nc @@ -490,6 +553,15 @@ atm/cam/physprops/iceoptics_c080917.nc atm/cam/physprops/F_nwvl200_mu20_lam50_res64_t298_c080428.nc + +gammadist +mitchell +atm/cam/physprops/iceoptics_c080917.nc +atm/cam/physprops/F_nwvl200_mu20_lam50_res64_t298_c080428.nc + +src/physics/rrtmgp/ext/rrtmgp/data/rrtmgp-data-lw-g128-210809.nc +src/physics/rrtmgp/ext/rrtmgp/data/rrtmgp-data-sw-g112-210809.nc + atm/cam/rad/abs_ems_factors_fastvx.c030508.nc diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 14b0dcfc8c..1ad86f2bdc 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -5219,7 +5219,7 @@ Default: Unused + group="phys_ctl_nl" valid_values="rrtmgp,rrtmg,camrt" > Type of radiation scheme employed. Default: set by build-namelist @@ -5409,6 +5409,25 @@ Switch to turn on Fixed Dynamical Heating in the offline radiation tool (PORT). Default: false + + + +Relative pathname for LW gas optics coefficients for RRTMGP. This data is +part of the RRTMGP source, thus this pathname is relative to the root source +code directory for the CAM component. +Default: set by build-namelist. + + + +Relative pathname for SW gas optics coefficients for RRTMGP. This data is +part of the RRTMGP source, thus this pathname is relative to the root source +code directory for the CAM component. +Default: set by build-namelist. + + + max_bound ) then + err_message = "validate: array values too large" + end if + end subroutine + + subroutine check_bounds_2d(arr, max_bound, min_bound, err_message) + real(r8), intent(in) :: arr(:,:) + real(r8), intent(in) :: max_bound, min_bound + character(len=128), intent(out) :: err_message + real(r8) :: mx, mn + err_message = '' + mx = maxval(arr) + mn = minval(arr) + if (mn < min_bound) then + err_message = "validate: array values too small " + end if + if (mx > max_bound ) then + err_message = "validate: array values too large" + end if + end subroutine + + subroutine check_bounds_3d(arr, max_bound, min_bound, err_message) + real(r8), intent(in) :: arr(:,:,:) + real(r8), intent(in) :: max_bound, min_bound + character(len=128), intent(out) :: err_message + real(r8) :: mx, mn + err_message = '' + mx = maxval(arr) + mn = minval(arr) + if (mn < min_bound) then + err_message = "validate: array values too small " + end if + if (mx > max_bound ) then + err_message = "validate: array values too large" + end if + end subroutine + + subroutine check_bounds_4d(arr, max_bound, min_bound, err_message) + real(r8), intent(in) :: arr(:,:,:,:) + real(r8), intent(in) :: max_bound, min_bound + character(len=128), intent(out) :: err_message + real(r8) :: mx, mn + err_message = '' + mx = maxval(arr) + mn = minval(arr) + if (mn < min_bound) then + err_message = "validate: array values too small " + end if + if (mx > max_bound ) then + err_message = "validate: array values too large" + end if + end subroutine + + subroutine check_bounds_5d(arr, max_bound, min_bound, err_message) + real(r8), intent(in) :: arr(:,:,:,:,:) + real(r8), intent(in) :: max_bound, min_bound + character(len=128), intent(out) :: err_message + real(r8) :: mx, mn + err_message = '' + mx = maxval(arr) + mn = minval(arr) + if (mn < min_bound) then + err_message = "validate: array values too small " + end if + if (mx > max_bound ) then + err_message = "validate: array values too large" + end if + end subroutine + + subroutine check_bounds_gas_concs(ncol, nlay, gasconcs, err_message) + integer, intent(in) :: ncol, nlay + type(ty_gas_concs), intent(in) :: gasconcs + character(len=128), intent(out) :: err_message + character(32), dimension(gasconcs%get_num_gases()) :: gc_gas_names + integer :: i + real(r8) :: vmr(ncol,nlay) + gc_gas_names(:) = gasconcs%get_gas_names() + do i = 1, gasconcs%get_num_gases() + err_message = gasconcs%get_vmr(gc_gas_names(i), vmr) ! gets values in vmr + if (len_trim(err_message) > 0) then + call endrun('check_bounds_gas_concs: error getting VMR for '//gc_gas_names(i)//' --> Error Message: '//trim(err_message)) + end if + call check_bounds(vmr, 1.0_r8, 0.0_r8, err_message) + if (len_trim(err_message) > 0) then + err_message = 'check_bounds_gas_concs: VMR error for '//gc_gas_names(i)//' --> Error Message: '//trim(err_message) + end if + end do + end subroutine + + subroutine check_bounds_gas_optics(kdist, err_message) + type(ty_gas_optics_rrtmgp), intent(in) :: kdist + character(len=128), intent(out) :: err_message + write(iulog,*) '[check_bonds_gas_optics DRAFT] : kdist' + ! write(iulog,*) 'number of gases: ',kdist%get_ngas() + ! write(iulog,*) 'gas names: ',kdist%get_gases() + ! write(iulog,*) 'kdist%source_is_external() = ',kdist%source_is_external() + err_message = "" + end subroutine + + + subroutine assert_shape_2dreal(arr, shp, err_message) + real(r8), intent(in) :: arr(:,:) ! 2-D array to check + integer, intent(in) :: shp(2) ! Expected shape + character(len=*), intent(out) :: err_message + character(len=512) :: err_append + integer :: r ! rank of arr + integer :: i + r = RANK(arr) + err_message = '' + if (r .ne. SIZE(shp)) then + err_message = 'Array is wrong rank (how could that happen?).' + end if + if (len_trim(err_message) == 0) then + do i = 1,r + if (SIZE(arr, i) /= shp(i)) then + write(err_append, "(a39,i3,a2)") 'Array size does not match on Dimension ', i, '._' + err_message = trim(err_message) // trim(err_append) + end if + end do + end if +end subroutine + +end module b_checker diff --git a/src/physics/rrtmgp/cloud_rad_props.F90 b/src/physics/rrtmgp/cloud_rad_props.F90 new file mode 100644 index 0000000000..1099fb714a --- /dev/null +++ b/src/physics/rrtmgp/cloud_rad_props.F90 @@ -0,0 +1,840 @@ +module cloud_rad_props + +!------------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------------ + +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only: pcols, pver, pverp +use physics_types, only: physics_state +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx +use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag +use cam_abortutils, only: endrun +use rad_constituents, only: iceopticsfile, liqopticsfile +use oldcloud, only: oldcloud_lw, old_liq_get_rad_props_lw, old_ice_get_rad_props_lw, oldcloud_init + +use ebert_curry, only: scalefactor +use cam_logfile, only: iulog + +use interpolate_data, only: interp_type, lininterp_init, lininterp, & + extrap_method_bndry, lininterp_finish + +implicit none +private +save + +public :: & + cloud_rad_props_init, & + get_ice_optics_sw, & ! return Mitchell SW ice radiative properties + ice_cloud_get_rad_props_lw, & ! return Mitchell LW ice radiative properties + get_liquid_optics_sw, & ! return Conley SW radiative properties + liquid_cloud_get_rad_props_lw, & ! return Conley LW radiative properties + grau_cloud_get_rad_props_lw, & + get_grau_optics_sw, & + snow_cloud_get_rad_props_lw, & + get_snow_optics_sw, & + ! NOTE: Are these required, or are they obsolete? + cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols (?) + cloud_rad_props_get_lw ! return LW optical props of total bulk aerosols (?) + +integer :: nmu, nlambda +real(r8), allocatable :: g_mu(:) ! mu samples on grid +real(r8), allocatable :: g_lambda(:,:) ! lambda scale samples on grid +real(r8), allocatable :: ext_sw_liq(:,:,:) +real(r8), allocatable :: ssa_sw_liq(:,:,:) +real(r8), allocatable :: asm_sw_liq(:,:,:) +real(r8), allocatable :: abs_lw_liq(:,:,:) + +integer :: n_g_d +real(r8), allocatable :: g_d_eff(:) ! radiative effective diameter samples on grid +real(r8), allocatable :: ext_sw_ice(:,:) +real(r8), allocatable :: ssa_sw_ice(:,:) +real(r8), allocatable :: asm_sw_ice(:,:) +real(r8), allocatable :: abs_lw_ice(:,:) + +! +! indexes into pbuf for optical parameters of MG clouds +! + integer :: i_dei, i_mu, i_lambda, i_iciwp, i_iclwp, i_des, i_icswp + integer :: i_degrau, i_icgrauwp + +! indexes into constituents for old optics + integer :: & + ixcldice, & ! cloud ice water index + ixcldliq ! cloud liquid water index + + +!============================================================================== +contains +!============================================================================== + +subroutine cloud_rad_props_init() + + use netcdf + use spmd_utils, only: masterproc + use ioFileMod, only: getfil + use error_messages, only: handle_ncerr +#if ( defined SPMD ) + use mpishorthand +#endif + use constituents, only: cnst_get_ind + use slingo, only: slingo_rad_props_init + use ebert_curry, only: ec_rad_props_init, scalefactor + + character(len=256) :: liquidfile + character(len=256) :: icefile + character(len=256) :: locfn + + integer :: ncid, dimid, f_nlwbands, f_nswbands, ierr + integer :: vdimids(NF90_MAX_VAR_DIMS), ndims, templen + ! liquid clouds + integer :: mudimid, lambdadimid + integer :: mu_id, lambda_id, ext_sw_liq_id, ssa_sw_liq_id, asm_sw_liq_id, abs_lw_liq_id + + ! ice clouds + integer :: d_dimid ! diameters + integer :: d_id, ext_sw_ice_id, ssa_sw_ice_id, asm_sw_ice_id, abs_lw_ice_id + + integer :: err + + liquidfile = liqopticsfile + icefile = iceopticsfile + + call slingo_rad_props_init + call ec_rad_props_init + call oldcloud_init + + i_dei = pbuf_get_index('DEI',errcode=err) + i_mu = pbuf_get_index('MU',errcode=err) + i_lambda = pbuf_get_index('LAMBDAC',errcode=err) + i_iciwp = pbuf_get_index('ICIWP',errcode=err) + i_iclwp = pbuf_get_index('ICLWP',errcode=err) + i_des = pbuf_get_index('DES',errcode=err) + i_icswp = pbuf_get_index('ICSWP',errcode=err) + i_icgrauwp = pbuf_get_index('ICGRAUWP',errcode=err) ! Available when using MG3 + i_degrau = pbuf_get_index('DEGRAU',errcode=err) ! Available when using MG3 + + ! old optics + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('CLDLIQ', ixcldliq) + + ! read liquid cloud optics + if (masterproc) then + call getfil( trim(liquidfile), locfn, 0) + call handle_ncerr( nf90_open(locfn, NF90_NOWRITE, ncid), 'liquid optics file missing') + write(iulog,*)' reading liquid cloud optics from file ',locfn + + 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') + + 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') + + 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') + + call handle_ncerr(nf90_inq_dimid( ncid, 'lambda_scale', lambdadimid), 'getting lambda dim') + call handle_ncerr(nf90_inquire_dimension( ncid, lambdadimid, len=nlambda), 'getting n lambda samples') + end if ! if (masterproc) + +#if ( defined SPMD ) + call mpibcast(nmu, 1, mpiint, 0, mpicom, ierr) + call mpibcast(nlambda, 1, mpiint, 0, mpicom, ierr) +#endif + + if (.not.allocated(g_mu)) allocate(g_mu(nmu)) + if (.not.allocated(g_lambda)) allocate(g_lambda(nmu,nlambda)) + if (.not.allocated(ext_sw_liq)) allocate(ext_sw_liq(nmu,nlambda,nswbands) ) + if (.not.allocated(ssa_sw_liq)) allocate(ssa_sw_liq(nmu,nlambda,nswbands)) + if (.not.allocated(asm_sw_liq)) allocate(asm_sw_liq(nmu,nlambda,nswbands)) + if (.not.allocated(abs_lw_liq)) allocate(abs_lw_liq(nmu,nlambda,nlwbands)) + + if (masterproc) then + call handle_ncerr( nf90_inq_varid(ncid, 'mu', mu_id),& + 'cloud optics mu get') + call handle_ncerr( nf90_get_var(ncid, mu_id, g_mu),& + 'read cloud optics mu values') + + call handle_ncerr( nf90_inq_varid(ncid, 'lambda', lambda_id),& + 'cloud optics lambda get') + call handle_ncerr( nf90_get_var(ncid, lambda_id, g_lambda),& + 'read cloud optics lambda values') + + call handle_ncerr( nf90_inq_varid(ncid, 'k_ext_sw', ext_sw_liq_id),& + 'cloud optics ext_sw_liq get') + call handle_ncerr( nf90_get_var(ncid, ext_sw_liq_id, ext_sw_liq),& + 'read cloud optics ext_sw_liq values') + + call handle_ncerr( nf90_inq_varid(ncid, 'ssa_sw', ssa_sw_liq_id),& + 'cloud optics ssa_sw_liq get') + call handle_ncerr( nf90_get_var(ncid, ssa_sw_liq_id, ssa_sw_liq),& + 'read cloud optics ssa_sw_liq values') + + call handle_ncerr( nf90_inq_varid(ncid, 'asm_sw', asm_sw_liq_id),& + 'cloud optics asm_sw_liq get') + call handle_ncerr( nf90_get_var(ncid, asm_sw_liq_id, asm_sw_liq),& + 'read cloud optics asm_sw_liq values') + + call handle_ncerr( nf90_inq_varid(ncid, 'k_abs_lw', abs_lw_liq_id),& + 'cloud optics abs_lw_liq get') + call handle_ncerr( nf90_get_var(ncid, abs_lw_liq_id, abs_lw_liq),& + 'read cloud optics abs_lw_liq values') + + call handle_ncerr( nf90_close(ncid), 'liquid optics file missing') + end if ! if masterproc + +#if ( defined SPMD ) + call mpibcast(g_mu, nmu, mpir8, 0, mpicom, ierr) + call mpibcast(g_lambda, nmu*nlambda, mpir8, 0, mpicom, ierr) + call mpibcast(ext_sw_liq, nmu*nlambda*nswbands, mpir8, 0, mpicom, ierr) + call mpibcast(ssa_sw_liq, nmu*nlambda*nswbands, mpir8, 0, mpicom, ierr) + call mpibcast(asm_sw_liq, nmu*nlambda*nswbands, mpir8, 0, mpicom, ierr) + call mpibcast(abs_lw_liq, nmu*nlambda*nlwbands, mpir8, 0, mpicom, ierr) +#endif + ! I forgot to convert kext from m^2/Volume to m^2/Kg + ext_sw_liq = ext_sw_liq / 0.9970449e3_r8 + abs_lw_liq = abs_lw_liq / 0.9970449e3_r8 + + ! read ice cloud optics + if (masterproc) then + call getfil( trim(icefile), locfn, 0) + call handle_ncerr( nf90_open(locfn, NF90_NOWRITE, ncid), 'ice optics file missing') + write(iulog,*)' reading ice cloud optics from file ',locfn + 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') + 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') + 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') + end if ! if (masterproc) + +#if ( defined SPMD ) + call mpibcast(n_g_d, 1, mpiint, 0, mpicom, ierr) +! call mpibcast(nswbands, 1, mpiint, 0, mpicom, ierr) +! call mpibcast(nlwbands, 1, mpiint, 0, mpicom, ierr) +#endif + + if (.not.allocated(g_d_eff)) allocate(g_d_eff(n_g_d)) + if (.not.allocated(ext_sw_ice)) allocate(ext_sw_ice(n_g_d,nswbands)) + if (.not.allocated(ssa_sw_ice)) allocate(ssa_sw_ice(n_g_d,nswbands)) + if (.not.allocated(asm_sw_ice)) allocate(asm_sw_ice(n_g_d,nswbands)) + if (.not.allocated(abs_lw_ice)) allocate(abs_lw_ice(n_g_d,nlwbands)) + + if (masterproc) then + call handle_ncerr( nf90_inq_varid(ncid, 'd_eff', d_id),& + 'cloud optics deff get') + call handle_ncerr( nf90_get_var(ncid, d_id, g_d_eff),& + 'read cloud optics deff values') + + call handle_ncerr( nf90_inq_varid(ncid, 'sw_ext', ext_sw_ice_id),& + 'cloud optics ext_sw_ice get') + call handle_ncerr(nf90_inquire_variable ( ncid, ext_sw_ice_id, ndims=ndims, dimids=vdimids),& + 'checking dimensions of ext_sw_ice') + call handle_ncerr(nf90_inquire_dimension( ncid, vdimids(1), len=templen),& + 'getting first dimension sw_ext') + call handle_ncerr(nf90_inquire_dimension( ncid, vdimids(2), len=templen),& + 'getting first dimension sw_ext') + call handle_ncerr( nf90_get_var(ncid, ext_sw_ice_id, ext_sw_ice),& + 'read cloud optics ext_sw_ice values') + + call handle_ncerr( nf90_inq_varid(ncid, 'sw_ssa', ssa_sw_ice_id),& + 'cloud optics ssa_sw_ice get') + call handle_ncerr( nf90_get_var(ncid, ssa_sw_ice_id, ssa_sw_ice),& + 'read cloud optics ssa_sw_ice values') + + call handle_ncerr( nf90_inq_varid(ncid, 'sw_asm', asm_sw_ice_id),& + 'cloud optics asm_sw_ice get') + call handle_ncerr( nf90_get_var(ncid, asm_sw_ice_id, asm_sw_ice),& + 'read cloud optics asm_sw_ice values') + + call handle_ncerr( nf90_inq_varid(ncid, 'lw_abs', abs_lw_ice_id),& + 'cloud optics abs_lw_ice get') + call handle_ncerr( nf90_get_var(ncid, abs_lw_ice_id, abs_lw_ice),& + 'read cloud optics abs_lw_ice values') + + call handle_ncerr( nf90_close(ncid), 'ice optics file missing') + end if ! if masterproc + +#if ( defined SPMD ) + call mpibcast(g_d_eff, n_g_d, mpir8, 0, mpicom, ierr) + call mpibcast(ext_sw_ice, n_g_d*nswbands, mpir8, 0, mpicom, ierr) + call mpibcast(ssa_sw_ice, n_g_d*nswbands, mpir8, 0, mpicom, ierr) + call mpibcast(asm_sw_ice, n_g_d*nswbands, mpir8, 0, mpicom, ierr) + call mpibcast(abs_lw_ice, n_g_d*nlwbands, mpir8, 0, mpicom, ierr) +#endif + + return + +end subroutine cloud_rad_props_init + +!============================================================================== + +subroutine cloud_rad_props_get_sw(state, pbuf, & + tau, tau_w, tau_w_g, tau_w_f,& + diagnosticindex, oldliq, oldice) + +! return totaled (across all species) layer tau, omega, g, f +! for all spectral interval for aerosols affecting the climate + + ! Arguments + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + integer, optional, intent(in) :: diagnosticindex ! index (if present) to radiation diagnostic information + + real(r8), intent(out) :: tau (nswbands,pcols,pver) ! aerosol extinction optical depth + real(r8), intent(out) :: tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau + real(r8), intent(out) :: tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w + real(r8), intent(out) :: tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w + + logical, optional, intent(in) :: oldliq,oldice + + ! Local variables + + integer :: ncol + integer :: lchnk + integer :: k, i ! lev and daycolumn indices + integer :: iswband ! sw band indices + + ! optical props for each aerosol + real(r8), pointer :: h_ext(:,:) + real(r8), pointer :: h_ssa(:,:) + real(r8), pointer :: h_asm(:,:) + real(r8), pointer :: n_ext(:) + real(r8), pointer :: n_ssa(:) + real(r8), pointer :: n_asm(:) + + ! rad properties for liquid clouds + real(r8) :: liq_tau (nswbands,pcols,pver) ! aerosol extinction optical depth + real(r8) :: liq_tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau + real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w + real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w + + ! rad properties for ice clouds + real(r8) :: ice_tau (nswbands,pcols,pver) ! aerosol extinction optical depth + real(r8) :: ice_tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau + real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w + real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w + + !----------------------------------------------------------------------------- + + ncol = state%ncol + lchnk = state%lchnk + + ! initialize to conditions that would cause failure + tau (:,:,:) = -100._r8 + tau_w (:,:,:) = -100._r8 + tau_w_g (:,:,:) = -100._r8 + tau_w_f (:,:,:) = -100._r8 + + ! initialize layers to accumulate od's + tau (:,1:ncol,:) = 0._r8 + tau_w (:,1:ncol,:) = 0._r8 + tau_w_g(:,1:ncol,:) = 0._r8 + tau_w_f(:,1:ncol,:) = 0._r8 + + + call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) + + call get_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) + + tau (:,1:ncol,:) = liq_tau (:,1:ncol,:) + ice_tau (:,1:ncol,:) + tau_w (:,1:ncol,:) = liq_tau_w (:,1:ncol,:) + ice_tau_w (:,1:ncol,:) + tau_w_g(:,1:ncol,:) = liq_tau_w_g(:,1:ncol,:) + ice_tau_w_g(:,1:ncol,:) + tau_w_f(:,1:ncol,:) = liq_tau_w_f(:,1:ncol,:) + ice_tau_w_f(:,1:ncol,:) + +end subroutine cloud_rad_props_get_sw +!============================================================================== + +subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldliq, oldice, oldcloud) + +! Purpose: Compute cloud longwave absorption optical depth +! cloud_rad_props_get_lw() is called by radlw() + + ! Arguments + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer:: pbuf(:) + real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer + integer, optional, intent(in) :: diagnosticindex + logical, optional, intent(in) :: oldliq ! use old liquid optics + logical, optional, intent(in) :: oldice ! use old ice optics + logical, optional, intent(in) :: oldcloud ! use old optics for both (b4b) + + ! Local variables + + integer :: bnd_idx ! LW band index + integer :: i ! column index + integer :: k ! lev index + integer :: ncol ! number of columns + integer :: lchnk + + ! rad properties for liquid clouds + real(r8) :: liq_tau_abs_od(nlwbands,pcols,pver) ! liquid cloud absorption optical depth + + ! rad properties for ice clouds + real(r8) :: ice_tau_abs_od(nlwbands,pcols,pver) ! ice cloud absorption optical depth + + !----------------------------------------------------------------------------- + + ncol = state%ncol + lchnk = state%lchnk + + ! compute optical depths cld_absod + cld_abs_od = 0._r8 + + if(present(oldcloud))then + if(oldcloud) then + ! make diagnostic calls to these first to output ice and liq OD's + !call old_liq_get_rad_props_lw(state, pbuf, liq_tau_abs_od, oldliqwp=.false.) + !call old_ice_get_rad_props_lw(state, pbuf, ice_tau_abs_od, oldicewp=.false.) + ! This affects climate (cld_abs_od) + call oldcloud_lw(state,pbuf,cld_abs_od,oldwp=.false.) + return + endif + endif + + if(present(oldliq))then + if(oldliq) then + call old_liq_get_rad_props_lw(state, pbuf, liq_tau_abs_od, oldliqwp=.false.) + else + call liquid_cloud_get_rad_props_lw(state, pbuf, liq_tau_abs_od) + endif + else + call liquid_cloud_get_rad_props_lw(state, pbuf, liq_tau_abs_od) + endif + + if(present(oldice))then + if(oldice) then + call old_ice_get_rad_props_lw(state, pbuf, ice_tau_abs_od, oldicewp=.false.) + else + call ice_cloud_get_rad_props_lw(state, pbuf, ice_tau_abs_od) + endif + else + call ice_cloud_get_rad_props_lw(state, pbuf, ice_tau_abs_od) + endif + + cld_abs_od(:,1:ncol,:) = liq_tau_abs_od(:,1:ncol,:) + ice_tau_abs_od(:,1:ncol,:) + +end subroutine cloud_rad_props_get_lw + +!============================================================================== + +subroutine get_snow_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + + real(r8), pointer :: icswpth(:,:), des(:,:) + + ! This does the same thing as get_ice_optics_sw, except with a different + ! water path and effective diameter. + call pbuf_get_field(pbuf, i_icswp, icswpth) + call pbuf_get_field(pbuf, i_des, des) + + call interpolate_ice_optics_sw(state%ncol, icswpth, des, tau, tau_w, & + tau_w_g, tau_w_f) + +end subroutine get_snow_optics_sw + +!============================================================================== + +subroutine get_grau_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + + real(r8), pointer :: icgrauwpth(:,:), degrau(:,:) + + integer :: i,k + + ! This does the same thing as get_ice_optics_sw, except with a different + ! water path and effective diameter. + if((i_icgrauwp > 0) .and. (i_degrau > 0)) then + + call pbuf_get_field(pbuf, i_icgrauwp, icgrauwpth) + call pbuf_get_field(pbuf, i_degrau, degrau) + + call interpolate_ice_optics_sw(state%ncol, icgrauwpth, degrau, tau, tau_w, & + tau_w_g, tau_w_f) + do i = 1, pcols + do k = 1, pver + if (tau(idx_sw_diag,i,k).gt.100._r8) then + write(iulog,*) 'WARNING: SW Graupel Tau > 100 (i,k,icgrauwpth,degrau,tau):' + write(iulog,*) i,k,icgrauwpth(i,k), degrau(i,k), tau(idx_sw_diag,i,k) + end if + enddo + enddo + + else + call endrun('ERROR: Get_grau_optics_sw called when graupel properties not supported') + end if + +end subroutine get_grau_optics_sw + +!============================================================================== +! Private methods +!============================================================================== + +subroutine get_ice_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + + real(r8), pointer :: iciwpth(:,:), dei(:,:) + + ! Get relevant pbuf fields, and interpolate optical properties from + ! the lookup tables. + call pbuf_get_field(pbuf, i_iciwp, iciwpth) + call pbuf_get_field(pbuf, i_dei, dei) + + call interpolate_ice_optics_sw(state%ncol, iciwpth, dei, tau, tau_w, & + tau_w_g, tau_w_f) + +end subroutine get_ice_optics_sw + +!============================================================================== + +subroutine interpolate_ice_optics_sw(ncol, iciwpth, dei, tau, tau_w, & + tau_w_g, tau_w_f) + + integer, intent(in) :: ncol + real(r8), intent(in) :: iciwpth(pcols,pver) + real(r8), intent(in) :: dei(pcols,pver) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + + type(interp_type) :: dei_wgts + + integer :: i, k, swband + real(r8) :: ext(nswbands), ssa(nswbands), asm(nswbands) + + do k = 1,pver + do i = 1,ncol + if( iciwpth(i,k) < 1.e-80_r8 .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 + tau_w_g(:,i,k) = 0._r8 + tau_w_f(:,i,k) = 0._r8 + else + ! for each cell interpolate to find weights in g_d_eff grid. + call lininterp_init(g_d_eff, n_g_d, dei(i:i,k), 1, & + extrap_method_bndry, dei_wgts) + ! interpolate into grid and extract radiative properties + do swband = 1, nswbands + call lininterp(ext_sw_ice(:,swband), n_g_d, & + ext(swband:swband), 1, dei_wgts) + call lininterp(ssa_sw_ice(:,swband), n_g_d, & + ssa(swband:swband), 1, dei_wgts) + call lininterp(asm_sw_ice(:,swband), n_g_d, & + asm(swband:swband), 1, dei_wgts) + end do + tau (:,i,k) = iciwpth(i,k) * ext + tau_w (:,i,k) = tau(:,i,k) * ssa + tau_w_g(:,i,k) = tau_w(:,i,k) * asm + tau_w_f(:,i,k) = tau_w_g(:,i,k) * asm + call lininterp_finish(dei_wgts) + endif + enddo + enddo + +end subroutine interpolate_ice_optics_sw + +!============================================================================== + +subroutine get_liquid_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + + real(r8), pointer, dimension(:,:) :: lamc, pgam, iclwpth + real(r8), dimension(pcols,pver) :: kext + integer i,k,swband,lchnk,ncol + + lchnk = state%lchnk + ncol = state%ncol + + + call pbuf_get_field(pbuf, i_lambda, lamc) + call pbuf_get_field(pbuf, i_mu, pgam) + call pbuf_get_field(pbuf, i_iclwp, iclwpth) + + do k = 1,pver + do i = 1,ncol + if(lamc(i,k) > 0._r8) then ! This seems to be clue from microphysics of no cloud + call gam_liquid_sw(iclwpth(i,k), lamc(i,k), pgam(i,k), & + tau(1:nswbands,i,k), tau_w(1:nswbands,i,k), tau_w_g(1:nswbands,i,k), tau_w_f(1:nswbands,i,k)) + else + tau(1:nswbands,i,k) = 0._r8 + tau_w(1:nswbands,i,k) = 0._r8 + tau_w_g(1:nswbands,i,k) = 0._r8 + tau_w_f(1:nswbands,i,k) = 0._r8 + endif + enddo + enddo + +end subroutine get_liquid_optics_sw + +!============================================================================== + +subroutine liquid_cloud_get_rad_props_lw(state, pbuf, abs_od) + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) + + integer :: lchnk, ncol + real(r8), pointer, dimension(:,:) :: lamc, pgam, iclwpth + + integer lwband, i, k + + abs_od = 0._r8 + + lchnk = state%lchnk + ncol = state%ncol + + call pbuf_get_field(pbuf, i_lambda, lamc) + call pbuf_get_field(pbuf, i_mu, pgam) + call pbuf_get_field(pbuf, i_iclwp, iclwpth) + + do k = 1,pver + do i = 1,ncol + if(lamc(i,k) > 0._r8) then ! This seems to be the clue for no cloud from microphysics formulation + call gam_liquid_lw(iclwpth(i,k), lamc(i,k), pgam(i,k), abs_od(1:nlwbands,i,k)) + else + abs_od(1:nlwbands,i,k) = 0._r8 + endif + enddo + enddo + +end subroutine liquid_cloud_get_rad_props_lw +!============================================================================== + +subroutine snow_cloud_get_rad_props_lw(state, pbuf, abs_od) + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) + + real(r8), pointer :: icswpth(:,:), des(:,:) + + ! This does the same thing as ice_cloud_get_rad_props_lw, except with a + ! different water path and effective diameter. + call pbuf_get_field(pbuf, i_icswp, icswpth) + call pbuf_get_field(pbuf, i_des, des) + + call interpolate_ice_optics_lw(state%ncol,icswpth, des, abs_od) + +end subroutine snow_cloud_get_rad_props_lw + + +!============================================================================== + +subroutine grau_cloud_get_rad_props_lw(state, pbuf, abs_od) + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) + + real(r8), pointer :: icgrauwpth(:,:), degrau(:,:) + + ! This does the same thing as ice_cloud_get_rad_props_lw, except with a + ! different water path and effective diameter. + if((i_icgrauwp > 0) .and. (i_degrau > 0)) then + call pbuf_get_field(pbuf, i_icgrauwp, icgrauwpth) + call pbuf_get_field(pbuf, i_degrau, degrau) + + call interpolate_ice_optics_lw(state%ncol,icgrauwpth, degrau, abs_od) + else + call endrun('ERROR: Grau_cloud_get_rad_props_lw called when graupel & + &properties not supported') + end if + +end subroutine grau_cloud_get_rad_props_lw + +!============================================================================== + +subroutine ice_cloud_get_rad_props_lw(state, pbuf, abs_od) + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) + + real(r8), pointer :: iciwpth(:,:), dei(:,:) + + ! Get relevant pbuf fields, and interpolate optical properties from + ! the lookup tables. + call pbuf_get_field(pbuf, i_iciwp, iciwpth) + call pbuf_get_field(pbuf, i_dei, dei) + + call interpolate_ice_optics_lw(state%ncol,iciwpth, dei, abs_od) + +end subroutine ice_cloud_get_rad_props_lw + +!============================================================================== + +subroutine interpolate_ice_optics_lw(ncol, iciwpth, dei, abs_od) + + integer, intent(in) :: ncol + real(r8), intent(in) :: iciwpth(pcols,pver) + real(r8), intent(in) :: dei(pcols,pver) + + real(r8),intent(out) :: abs_od(nlwbands,pcols,pver) + + type(interp_type) :: dei_wgts + + integer :: i, k, lwband + real(r8) :: absor(nlwbands) + + 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 + abs_od (:,i,k) = 0._r8 + else + ! for each cell interpolate to find weights in g_d_eff grid. + call lininterp_init(g_d_eff, n_g_d, dei(i:i,k), 1, & + extrap_method_bndry, dei_wgts) + ! interpolate into grid and extract radiative properties + do lwband = 1, nlwbands + call lininterp(abs_lw_ice(:,lwband), n_g_d, & + absor(lwband:lwband), 1, dei_wgts) + enddo + abs_od(:,i,k) = iciwpth(i,k) * absor + where(abs_od(:,i,k) > 50.0_r8) abs_od(:,i,k) = 50.0_r8 + call lininterp_finish(dei_wgts) + endif + enddo + enddo + +end subroutine interpolate_ice_optics_lw + +!============================================================================== + +subroutine gam_liquid_lw(clwptn, lamc, pgam, abs_od) + real(r8), intent(in) :: clwptn ! cloud water liquid path new (in cloud) (in g/m^2)? + real(r8), intent(in) :: lamc ! prognosed value of lambda for cloud + real(r8), intent(in) :: pgam ! prognosed value of mu for cloud + real(r8), intent(out) :: abs_od(1:nlwbands) + + integer :: lwband ! sw band index + + type(interp_type) :: mu_wgts + type(interp_type) :: lambda_wgts + + if (clwptn < 1.e-80_r8) then + abs_od = 0._r8 + return + endif + + call get_mu_lambda_weights(lamc, pgam, mu_wgts, lambda_wgts) + + do lwband = 1, nlwbands + call lininterp(abs_lw_liq(:,:,lwband), nmu, nlambda, & + abs_od(lwband:lwband), 1, mu_wgts, lambda_wgts) + enddo + + abs_od = clwptn * abs_od + + call lininterp_finish(mu_wgts) + call lininterp_finish(lambda_wgts) + +end subroutine gam_liquid_lw + +!============================================================================== + +subroutine gam_liquid_sw(clwptn, lamc, pgam, tau, tau_w, tau_w_g, tau_w_f) + real(r8), intent(in) :: clwptn ! cloud water liquid path new (in cloud) (in g/m^2)? + real(r8), intent(in) :: lamc ! prognosed value of lambda for cloud + real(r8), intent(in) :: pgam ! prognosed value of mu for cloud + real(r8), intent(out) :: tau(1:nswbands), tau_w(1:nswbands), tau_w_f(1:nswbands), tau_w_g(1:nswbands) + + integer :: swband ! sw band index + + real(r8) :: ext(nswbands), ssa(nswbands), asm(nswbands) + + type(interp_type) :: mu_wgts + type(interp_type) :: lambda_wgts + + if (clwptn < 1.e-80_r8) then + tau = 0._r8 + tau_w = 0._r8 + tau_w_g = 0._r8 + tau_w_f = 0._r8 + return + endif + + call get_mu_lambda_weights(lamc, pgam, mu_wgts, lambda_wgts) + + do swband = 1, nswbands + call lininterp(ext_sw_liq(:,:,swband), nmu, nlambda, & + ext(swband:swband), 1, mu_wgts, lambda_wgts) + call lininterp(ssa_sw_liq(:,:,swband), nmu, nlambda, & + ssa(swband:swband), 1, mu_wgts, lambda_wgts) + call lininterp(asm_sw_liq(:,:,swband), nmu, nlambda, & + asm(swband:swband), 1, mu_wgts, lambda_wgts) + enddo + + ! compute radiative properties + tau = clwptn * ext + tau_w = tau * ssa + tau_w_g = tau_w * asm + tau_w_f = tau_w_g * asm + + call lininterp_finish(mu_wgts) + call lininterp_finish(lambda_wgts) + +end subroutine gam_liquid_sw + +!============================================================================== + +subroutine get_mu_lambda_weights(lamc, pgam, mu_wgts, lambda_wgts) + real(r8), intent(in) :: lamc ! prognosed value of lambda for cloud + real(r8), intent(in) :: pgam ! prognosed value of mu for cloud + ! Output interpolation weights. Caller is responsible for freeing these. + type(interp_type), intent(out) :: mu_wgts + type(interp_type), intent(out) :: lambda_wgts + + integer :: ilambda + real(r8) :: g_lambda_interp(nlambda) + + ! Make interpolation weights for mu. + ! (Put pgam in a temporary array for this purpose.) + call lininterp_init(g_mu, nmu, [pgam], 1, extrap_method_bndry, mu_wgts) + + ! Use mu weights to interpolate to a row in the lambda table. + do ilambda = 1, nlambda + call lininterp(g_lambda(:,ilambda), nmu, & + g_lambda_interp(ilambda:ilambda), 1, mu_wgts) + end do + + ! Make interpolation weights for lambda. + call lininterp_init(g_lambda_interp, nlambda, [lamc], 1, & + extrap_method_bndry, lambda_wgts) + +end subroutine get_mu_lambda_weights + +!============================================================================== + +end module cloud_rad_props diff --git a/src/physics/rrtmgp/ebert_curry.F90 b/src/physics/rrtmgp/ebert_curry.F90 new file mode 100644 index 0000000000..a1e1c031b1 --- /dev/null +++ b/src/physics/rrtmgp/ebert_curry.F90 @@ -0,0 +1,408 @@ +module ebert_curry + +!------------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------------ + +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only: pcols, pver, pverp +use physics_types, only: physics_state +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx +use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag, get_sw_spectral_boundaries +use cam_abortutils, only: endrun +use cam_history, only: outfld + +implicit none +private +save + +public :: & + ec_rad_props_init, & + cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols + cloud_rad_props_get_lw, & ! return LW optical props of total bulk aerosols + ec_ice_optics_sw, & + ec_ice_get_rad_props_lw + + +real(r8), public, parameter:: scalefactor = 1._r8 !500._r8/917._r8 + +! Minimum cloud amount (as a fraction of the grid-box area) to +! distinguish from clear sky +! + real(r8) cldmin + parameter (cldmin = 1.0e-80_r8) +! +! Decimal precision of cloud amount (0 -> preserve full resolution; +! 10^-n -> preserve n digits of cloud amount) +! + real(r8) cldeps + parameter (cldeps = 0.0_r8) + +! +! indexes into pbuf for optical parameters of MG clouds +! + integer :: dei_idx = 0 + integer :: mu_idx = 0 + integer :: lambda_idx = 0 + integer :: iciwp_idx = 0 + integer :: iclwp_idx = 0 + integer :: cld_idx = 0 + integer :: rei_idx = 0 + +! indexes into constituents for old optics + integer :: & + ixcldice, & ! cloud ice water index + ixcldliq ! cloud liquid water index + + +!============================================================================== +contains +!============================================================================== + +subroutine ec_rad_props_init() + +! use cam_history, only: addfld + use netcdf + use spmd_utils, only: masterproc + use ioFileMod, only: getfil + use cam_logfile, only: iulog + use error_messages, only: handle_ncerr +#if ( defined SPMD ) + use mpishorthand +#endif + use constituents, only: cnst_get_ind + + integer :: err + + iciwp_idx = pbuf_get_index('ICIWP',errcode=err) + iclwp_idx = pbuf_get_index('ICLWP',errcode=err) + cld_idx = pbuf_get_index('CLD') + rei_idx = pbuf_get_index('REI') + + ! old optics + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('CLDLIQ', ixcldliq) + + !call addfld ('CLWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','old In Cloud Liquid Water Path', sampling_seq='rad_lwsw') + !call addfld ('KEXT_OLD',(/ 'lev' /),'I','m^2/kg','old extinction') + !call addfld ('CLDOD_OLD',(/ 'lev' /),'I','1','old liquid OD') + !call addfld ('REL_OLD',(/ 'lev' /),'I','1','old liquid effective radius (liquid)') + + !call addfld ('CLWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Liquid Water Path', sampling_seq='rad_lwsw') + !call addfld ('KEXT_NEW',(/ 'lev' /),'I','m^2/kg','extinction') + !call addfld ('CLDOD_NEW',(/ 'lev' /),'I','1','liquid OD') + + !call addfld('CIWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path', sampling_seq='rad_lwsw') + !call addfld('CIWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path (old)', sampling_seq='rad_lwsw') + + return + +end subroutine ec_rad_props_init + +!============================================================================== + +subroutine cloud_rad_props_get_sw(state, pbuf, & + tau, tau_w, tau_w_g, tau_w_f,& + diagnosticindex, oldliq, oldice) + +! return totaled (across all species) layer tau, omega, g, f +! for all spectral interval for aerosols affecting the climate + + ! Arguments + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + integer, optional, intent(in) :: diagnosticindex ! index (if present) to radiation diagnostic information + + real(r8), intent(out) :: tau (nswbands,pcols,pver) ! aerosol extinction optical depth + real(r8), intent(out) :: tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau + real(r8), intent(out) :: tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w + real(r8), intent(out) :: tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w + + logical, optional, intent(in) :: oldliq,oldice + + ! Local variables + + integer :: ncol + integer :: lchnk + integer :: k, i ! lev and daycolumn indices + integer :: iswband ! sw band indices + + !----------------------------------------------------------------------------- + + ncol = state%ncol + lchnk = state%lchnk + + ! initialize to conditions that would cause failure + tau (:,:,:) = -100._r8 + tau_w (:,:,:) = -100._r8 + tau_w_g (:,:,:) = -100._r8 + tau_w_f (:,:,:) = -100._r8 + + ! initialize layers to accumulate od's + tau (:,1:ncol,:) = 0._r8 + tau_w (:,1:ncol,:) = 0._r8 + tau_w_g(:,1:ncol,:) = 0._r8 + tau_w_f(:,1:ncol,:) = 0._r8 + + + call ec_ice_optics_sw (state, pbuf, tau, tau_w, tau_w_g, tau_w_f, oldicewp=.true.) +! call outfld ('CI_OD_SW_OLD', ice_tau(idx_sw_diag,:,:), pcols, lchnk) + + +end subroutine cloud_rad_props_get_sw +!============================================================================== + +subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldliq, oldice, oldcloud) + +! Purpose: Compute cloud longwave absorption optical depth +! cloud_rad_props_get_lw() is called by radlw() + + ! Arguments + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer + integer, optional, intent(in) :: diagnosticindex + logical, optional, intent(in) :: oldliq ! use old liquid optics + logical, optional, intent(in) :: oldice ! use old ice optics + logical, optional, intent(in) :: oldcloud ! use old optics for both (b4b) + + ! Local variables + + integer :: bnd_idx ! LW band index + integer :: i ! column index + integer :: k ! lev index + integer :: ncol ! number of columns + integer :: lchnk + + !----------------------------------------------------------------------------- + + ncol = state%ncol + lchnk = state%lchnk + + ! compute optical depths cld_absod + cld_abs_od = 0._r8 + + call ec_ice_get_rad_props_lw(state, pbuf, cld_abs_od, oldicewp=.true.) + !call outfld('CI_OD_LW_OLD', ice_tau_abs_od(idx_lw_diag ,:,:), pcols, lchnk) + +end subroutine cloud_rad_props_get_lw + +!============================================================================== +! Private methods +!============================================================================== + +subroutine ec_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp) + + use physconst, only: gravit + + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + logical, intent(in) :: oldicewp + + real(r8), pointer, dimension(:,:) :: rei + real(r8), pointer, dimension(:,:) :: cldn + real(r8), pointer, dimension(:,:) :: tmpptr + real(r8), dimension(pcols,pver) :: cicewp + real(r8), dimension(nswbands) :: wavmin + real(r8), dimension(nswbands) :: wavmax + ! + ! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836) + real(r8) :: abari(4) = & ! a coefficient for extinction optical depth + (/ 3.448e-03_r8, 3.448e-03_r8,3.448e-03_r8,3.448e-03_r8/) + real(r8) :: bbari(4) = & ! b coefficient for extinction optical depth + (/ 2.431_r8 , 2.431_r8 ,2.431_r8 ,2.431_r8 /) + real(r8) :: cbari(4) = & ! c coefficient for single scat albedo + (/ 1.00e-05_r8 , 1.10e-04_r8 ,1.861e-02_r8,.46658_r8 /) + real(r8) :: dbari(4) = & ! d coefficient for single scat albedo + (/ 0.0_r8 , 1.405e-05_r8,8.328e-04_r8,2.05e-05_r8 /) + real(r8) :: ebari(4) = & ! e coefficient for asymmetry parameter + (/ 0.7661_r8 , 0.7730_r8 ,0.794_r8 ,0.9595_r8 /) + real(r8) :: fbari(4) = & ! f coefficient for asymmetry parameter + (/ 5.851e-04_r8, 5.665e-04_r8,7.267e-04_r8,1.076e-04_r8/) + + real(r8) :: abarii ! A coefficient for current spectral band + real(r8) :: bbarii ! B coefficient for current spectral band + real(r8) :: cbarii ! C coefficient for current spectral band + real(r8) :: dbarii ! D coefficient for current spectral band + real(r8) :: ebarii ! E coefficient for current spectral band + real(r8) :: fbarii ! F coefficient for current spectral band + + ! Minimum cloud amount (as a fraction of the grid-box area) to + ! distinguish from clear sky + real(r8), parameter :: cldmin = 1.0e-80_r8 + + ! Decimal precision of cloud amount (0 -> preserve full resolution; + ! 10^-n -> preserve n digits of cloud amount) + real(r8), parameter :: cldeps = 0.0_r8 + + integer :: ns, i, k, indxsl, lchnk, Nday + integer :: itim_old + real(r8) :: tmp1i, tmp2i, tmp3i, g + + Nday = state%ncol + lchnk = state%lchnk + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, cld_idx,cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, rei_idx,rei) + + if(oldicewp) then + do k=1,pver + do i = 1,Nday + cicewp(i,k) = 1000.0_r8*state%q(i,k,ixcldice)*state%pdel(i,k) /(gravit* max(0.01_r8,cldn(i,k))) + end do + end do + else + if (iciwp_idx<=0) then + call endrun('ec_ice_optics_sw: oldicewp must be set to true since ICIWP was not found in pbuf') + endif + call pbuf_get_field(pbuf, iciwp_idx, tmpptr) + cicewp(1:pcols,1:pver) = 1000.0_r8*tmpptr(1:pcols,1:pver) + endif + + call get_sw_spectral_boundaries(wavmin,wavmax,'microns') + + do ns = 1, nswbands + + if(wavmax(ns) <= 0.7_r8) then + indxsl = 1 + else if(wavmax(ns) <= 1.25_r8) then + indxsl = 2 + else if(wavmax(ns) <= 2.38_r8) then + indxsl = 3 + else if(wavmax(ns) > 2.38_r8) then + indxsl = 4 + end if + + abarii = abari(indxsl) + bbarii = bbari(indxsl) + cbarii = cbari(indxsl) + dbarii = dbari(indxsl) + ebarii = ebari(indxsl) + fbarii = fbari(indxsl) + + do k=1,pver + do i=1,Nday + + ! note that optical properties for ice valid only + ! in range of 13 > rei > 130 micron (Ebert and Curry 92) + if (cldn(i,k) >= cldmin .and. cldn(i,k) >= cldeps) then + tmp1i = abarii + bbarii/max(13._r8,min(scalefactor*rei(i,k),130._r8)) + ice_tau(ns,i,k) = cicewp(i,k)*tmp1i + else + ice_tau(ns,i,k) = 0.0_r8 + endif + + tmp2i = 1._r8 - cbarii - dbarii*min(max(13._r8,scalefactor*rei(i,k)),130._r8) + tmp3i = fbarii*min(max(13._r8,scalefactor*rei(i,k)),130._r8) + ! Do not let single scatter albedo be 1. Delta-eddington solution + ! for non-conservative case has different analytic form from solution + ! for conservative case, and raddedmx is written for non-conservative case. + ice_tau_w(ns,i,k) = ice_tau(ns,i,k) * min(tmp2i,.999999_r8) + g = ebarii + tmp3i + ice_tau_w_g(ns,i,k) = ice_tau_w(ns,i,k) * g + ice_tau_w_f(ns,i,k) = ice_tau_w(ns,i,k) * g * g + + end do ! End do i=1,Nday + end do ! End do k=1,pver + end do ! nswbands + +end subroutine ec_ice_optics_sw +!============================================================================== + +subroutine ec_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp) + use physconst, only: gravit + + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) + logical, intent(in) :: oldicewp + + real(r8) :: gicewp(pcols,pver) + real(r8) :: gliqwp(pcols,pver) + real(r8) :: cicewp(pcols,pver) + real(r8) :: cliqwp(pcols,pver) + real(r8) :: ficemr(pcols,pver) + real(r8) :: cwp(pcols,pver) + real(r8) :: cldtau(pcols,pver) + + real(r8), pointer, dimension(:,:) :: cldn + 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), pointer, dimension(:,:) :: iclwpth, iciwpth + + + ncol = state%ncol + lchnk = state%lchnk + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, rei_idx, rei) + call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + + if(oldicewp) then + do k=1,pver + do i = 1,ncol + gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path. + gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path. + cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. + cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. + ficemr(i,k) = state%q(i,k,ixcldice) / & + max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq))) + end do + end do + cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) + else + if (iclwp_idx<=0 .or. iciwp_idx<=0) then + call endrun('ec_ice_get_rad_props_lw: oldicewp must be set to true since ICIWP and/or ICLWP were not found in pbuf') + endif + call pbuf_get_field(pbuf, iclwp_idx, iclwpth) + call pbuf_get_field(pbuf, iciwp_idx, iciwpth) + do k=1,pver + do i = 1,ncol + cwp(i,k) = 1000.0_r8 *iciwpth(i,k) + 1000.0_r8 *iclwpth(i,k) + ficemr(i,k) = 1000.0_r8*iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k))) + end do + end do + endif + + do k=1,pver + do i=1,ncol + + ! Note from Andrew Conley: + ! Optics for RK no longer supported, This is constructed to get + ! close to bit for bit. Otherwise we could simply use ice water path + !note that optical properties for ice valid only + !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 + + !if(oldicewp) then + ! call outfld('CIWPTH_OLD',cicewp(:,:)/1000,pcols,lchnk) + !else + ! call outfld('CIWPTH_OLD',iciwpth(:,:),pcols,lchnk) + !endif + !call outfld('CI_OD_LW_OLD',cldtau(:,:),pcols,lchnk) + +end subroutine ec_ice_get_rad_props_lw +!============================================================================== + +end module ebert_curry diff --git a/src/physics/rrtmgp/mcica_subcol_gen.F90 b/src/physics/rrtmgp/mcica_subcol_gen.F90 new file mode 100644 index 0000000000..c77b20e4ed --- /dev/null +++ b/src/physics/rrtmgp/mcica_subcol_gen.F90 @@ -0,0 +1,293 @@ +module mcica_subcol_gen + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2006-2007, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (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. +! +! Uses the KISS random number generator. +! +! Overlap assumption: maximum-random. +! +!---------------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only: pcols, pver, pverp +use cam_abortutils, only: endrun + +use shr_RandNum_mod, only: ShrKissRandGen + +! old: use mo_gas_optics_specification, only: ty_gas_optics_specification +! use mo_gas_optics, only: ty_gas_optics ! Wrong? +use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp +use cam_logfile, only: iulog ! just for debugging (BPM) + +implicit none +private +save + +public :: mcica_subcol_lw, mcica_subcol_sw + +!======================================================================================== +contains +!======================================================================================== + +subroutine mcica_subcol_lw( & + kdist, nbnd, ngpt, ncol, changeseed, & + pmid, cldfrac, tauc, taucmcl) + + ! Arrays use CAM vertical index convention: index increases from top to bottom. + ! This index ordering is assumed in the maximum-random overlap algorithm which starts + ! at the top of a column and marches down, with each layer depending on the state + ! of the layer above it. + ! + ! For GCM mode, changeseed must be offset between LW and SW by at least the + ! 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) + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: changeseed ! if the subcolumn generator is called multiple times, + ! permute the seed between each call. + real(r8), intent(in) :: pmid(pcols,pver) ! layer pressures (Pa) + real(r8), intent(in) :: cldfrac(pcols,pver) ! layer cloud fraction + real(r8), intent(in) :: tauc(nbnd,pcols,pver) ! cloud optical depth + + real(r8), intent(out) :: taucmcl(ngpt,ncol,pver) ! subcolumn cloud optical depth [mcica] + + ! Local vars + + integer :: i, isubcol, k, n + + real(r8), parameter :: cldmin = 1.0e-80_r8 ! min cloud fraction + real(r8) :: cldf(ncol,pver) ! cloud fraction clipped to cldmin + + type(ShrKissRandGen) :: kiss_gen ! KISS RNG object + integer :: kiss_seed(ncol,4) + real(r8) :: rand_num_1d(ncol,1) ! random number (kissvec) + real(r8) :: rand_num(ncol,pver) ! random number (kissvec) + + real(r8) :: cdf(ngpt,ncol,pver) ! random numbers + logical :: iscloudy(ngpt,ncol,pver) ! flag that says whether a gridbox is cloudy + !------------------------------------------------------------------------------------------ + ! clip cloud fraction + cldf(:,:) = cldfrac(:ncol,:) + where (cldf(:,:) < cldmin) + cldf(:,:) = 0._r8 + end where + + ! Create a seed that depends on the state of the columns. + ! Use pmid from bottom four layers. + do i = 1, ncol + kiss_seed(i,1) = (pmid(i,pver) - int(pmid(i,pver))) * 1000000000 + kiss_seed(i,2) = (pmid(i,pver-1) - int(pmid(i,pver-1))) * 1000000000 + kiss_seed(i,3) = (pmid(i,pver-2) - int(pmid(i,pver-2))) * 1000000000 + kiss_seed(i,4) = (pmid(i,pver-3) - int(pmid(i,pver-3))) * 1000000000 + end do + + ! create the RNG object + kiss_gen = ShrKissRandGen(kiss_seed) + + ! Advance randum number generator by changeseed values + do i = 1, changeSeed + call kiss_gen%random(rand_num_1d) + end do + + ! Generate random numbers in each subcolumn at every level + do isubcol = 1,ngpt + call kiss_gen%random(rand_num) + cdf(isubcol,:,:) = rand_num(:,:) + enddo + + ! Maximum-Random overlap + ! i) pick a random number for top layer. + ! ii) walk down the column: + ! - if the layer above is cloudy, use the same random number as in the layer above + ! - if the layer above is clear, use a new random number + + do k = 2, pver + do i = 1, ncol + do isubcol = 1, ngpt + if (cdf(isubcol,i,k-1) > 1._r8 - cldf(i,k-1) ) then + cdf(isubcol,i,k) = cdf(isubcol,i,k-1) + else + cdf(isubcol,i,k) = cdf(isubcol,i,k) * (1._r8 - cldf(i,k-1)) + end if + end do + end do + end do + + do k = 1, pver + iscloudy(:,:,k) = (cdf(:,:,k) >= 1._r8 - spread(cldf(:,k), dim=1, nCopies=ngpt) ) + end do + + ! -- generate subcolumns for homogeneous clouds ----- + ! where there is a cloud, set the subcolumn cloud properties; + ! incoming tauc should be in-cloud quantites and not grid-averaged quantities + do k = 1,pver + do i = 1,ncol + do isubcol = 1,ngpt + if (iscloudy(isubcol,i,k) .and. (cldf(i,k) > 0._r8) ) then + n = kdist%convert_gpt2band(isubcol) + taucmcl(isubcol,i,k) = tauc(n,i,k) + else + taucmcl(isubcol,i,k) = 0._r8 + end if + end do + end do + end do + + call kiss_gen%finalize() + +end subroutine mcica_subcol_lw + +!======================================================================================== + +subroutine mcica_subcol_sw( & + kdist, nbnd, ngpt, ncol, nlay, nver, changeseed, & + pmid, cldfrac, tauc, ssac, asmc, & + taucmcl, ssacmcl, asmcmcl) + + ! Arrays use CAM vertical index convention: index increases from top to bottom. + ! This index ordering is assumed in the maximum-random overlap algorithm which starts + ! at the top of a column and marches down, with each layer depending on the state + ! of the layer above it. + ! + ! For GCM mode, changeseed must be offset between LW and SW by at least the + ! 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) + integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: nlay ! number of vertical layers in radiation calc; + ! may include an "extra layer" + integer, intent(in) :: nver ! number of CAM's vertical layers in rad calc + integer, intent(in) :: changeseed ! if the subcolumn generator is called multiple times, + ! permute the seed between each call. + real(r8), intent(in) :: pmid(ncol,nlay) ! layer midpoint pressures (Pa) + real(r8), intent(in) :: cldfrac(ncol,nver) ! layer cloud fraction + real(r8), intent(in) :: tauc(nbnd,ncol,nver) ! cloud optical depth + real(r8), intent(in) :: ssac(nbnd,ncol,nver) ! cloud single scattering albedo (non-delta scaled) + real(r8), intent(in) :: asmc(nbnd,ncol,nver) ! cloud asymmetry parameter (non-delta scaled) + + + real(r8), intent(out) :: taucmcl(ngpt,ncol,nver) ! subcolumn cloud optical depth [mcica] + real(r8), intent(out) :: ssacmcl(ngpt,ncol,nver) ! subcolumn cloud single scattering albedo [mcica] + real(r8), intent(out) :: asmcmcl(ngpt,ncol,nver) ! subcolumn cloud asymmetry parameter [mcica] + + ! Local vars + + integer :: i, isubcol, k, n + + real(r8), parameter :: cldmin = 1.0e-80_r8 ! min cloud fraction + real(r8) :: cldf(ncol,nver) ! cloud fraction clipped to cldmin + + type(ShrKissRandGen) :: kiss_gen ! KISS RNG object + integer :: kiss_seed(ncol,4) + real(r8) :: rand_num_1d(ncol,1) ! random number (kissvec) + real(r8) :: rand_num(ncol,nver) ! random number (kissvec) + + real(r8) :: cdf(ngpt,ncol,nver) ! random numbers + logical :: iscloudy(ngpt,ncol,nver) ! flag that says whether a gridbox is cloudy + !------------------------------------------------------------------------------------------ + + ! clip cloud fraction + cldf(:,:) = cldfrac(:ncol,:) + where (cldf(:,:) < cldmin) + cldf(:,:) = 0._r8 + end where + + ! Create a seed that depends on the state of the columns. + ! Use pmid from bottom four layers. + do i = 1, ncol + kiss_seed(i,1) = (pmid(i,nlay) - int(pmid(i,nlay))) * 1000000000 + kiss_seed(i,2) = (pmid(i,nlay-1) - int(pmid(i,nlay-1))) * 1000000000 + kiss_seed(i,3) = (pmid(i,nlay-2) - int(pmid(i,nlay-2))) * 1000000000 + kiss_seed(i,4) = (pmid(i,nlay-3) - int(pmid(i,nlay-3))) * 1000000000 + end do + + ! create the RNG object + kiss_gen = ShrKissRandGen(kiss_seed) + + ! Advance randum number generator by changeseed values + do i = 1, changeSeed + call kiss_gen%random(rand_num_1d) + end do + + ! Generate random numbers in each subcolumn at every level + do isubcol = 1,ngpt + call kiss_gen%random(rand_num) + cdf(isubcol,:,:) = rand_num(:,:) + enddo + + ! Maximum-Random overlap + ! i) pick a random number for top layer. + ! ii) walk down the column: + ! - if the layer above is cloudy, use the same random number as in the layer above + ! - if the layer above is clear, use a new random number + + do k = 2, nver + do i = 1, ncol + do isubcol = 1, ngpt + if (cdf(isubcol,i,k-1) > 1._r8 - cldf(i,k-1) ) then + cdf(isubcol,i,k) = cdf(isubcol,i,k-1) + else + cdf(isubcol,i,k) = cdf(isubcol,i,k) * (1._r8 - cldf(i,k-1)) + end if + end do + end do + end do + + do k = 1, nver + iscloudy(:,:,k) = (cdf(:,:,k) >= 1._r8 - spread(cldf(:,k), dim=1, nCopies=ngpt) ) + ! write(iulog,*) 'level ',k,' any(iscloud) = ',any(iscloudy(:,1,k)) ! BPM - Debugging - remove when done + end do + + ! -- generate subcolumns for homogeneous clouds ----- + ! where there is a cloud, set the subcolumn cloud properties; + ! incoming tauc should be in-cloud quantites and not grid-averaged quantities + do k = 1,nver + do i = 1,ncol + do isubcol = 1,ngpt + if (iscloudy(isubcol,i,k) .and. (cldf(i,k) > 0._r8) ) then + n = kdist%convert_gpt2band(isubcol) + taucmcl(isubcol,i,k) = tauc(n,i,k) + ssacmcl(isubcol,i,k) = ssac(n,i,k) + asmcmcl(isubcol,i,k) = asmc(n,i,k) + ! write(iulog,*) 'level ',k,' subcolumn ',isubcol, 'CLOUD! ssacmcl = ',ssacmcl(isubcol,i,k),', asmcmcl = ',asmcmcl(isubcol,i,k) ! BPM - Debugging - remove when done + else + taucmcl(isubcol,i,k) = 0._r8 + ssacmcl(isubcol,i,k) = 1._r8 + asmcmcl(isubcol,i,k) = 0._r8 + end if + end do + end do + end do + + call kiss_gen%finalize() + +end subroutine mcica_subcol_sw + + +end module mcica_subcol_gen + diff --git a/src/physics/rrtmgp/oldcloud.F90 b/src/physics/rrtmgp/oldcloud.F90 new file mode 100644 index 0000000000..609c6b4668 --- /dev/null +++ b/src/physics/rrtmgp/oldcloud.F90 @@ -0,0 +1,643 @@ +module oldcloud + +!------------------------------------------------------------------------------------------------ +!------------------------------------------------------------------------------------------------ + +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only: pcols, pver, pverp +use physics_types, only: physics_state +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field +use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag, get_sw_spectral_boundaries +use cam_abortutils, only: endrun +use cam_history, only: outfld +use rad_constituents, only: iceopticsfile, liqopticsfile +use ebert_curry, only: scalefactor + +implicit none +private +save + +public :: & + oldcloud_init, oldcloud_lw, old_liq_get_rad_props_lw, old_ice_get_rad_props_lw + +integer :: nmu, nlambda +real(r8), allocatable :: g_mu(:) ! mu samples on grid +real(r8), allocatable :: g_lambda(:,:) ! lambda scale samples on grid +real(r8), allocatable :: ext_sw_liq(:,:,:) +real(r8), allocatable :: ssa_sw_liq(:,:,:) +real(r8), allocatable :: asm_sw_liq(:,:,:) +real(r8), allocatable :: abs_lw_liq(:,:,:) + +integer :: n_g_d +real(r8), allocatable :: g_d_eff(:) ! radiative effective diameter samples on grid +real(r8), allocatable :: ext_sw_ice(:,:) +real(r8), allocatable :: ssa_sw_ice(:,:) +real(r8), allocatable :: asm_sw_ice(:,:) +real(r8), allocatable :: abs_lw_ice(:,:) + +! Minimum cloud amount (as a fraction of the grid-box area) to +! distinguish from clear sky +! + real(r8) cldmin + parameter (cldmin = 1.0e-80_r8) +! +! Decimal precision of cloud amount (0 -> preserve full resolution; +! 10^-n -> preserve n digits of cloud amount) +! + real(r8) cldeps + parameter (cldeps = 0.0_r8) + +! +! indexes into pbuf for optical parameters of MG clouds +! + integer :: iciwp_idx = 0 + integer :: iclwp_idx = 0 + integer :: cld_idx = 0 + integer :: rel_idx = 0 + integer :: rei_idx = 0 + +! indexes into constituents for old optics + integer :: & + ixcldice, & ! cloud ice water index + ixcldliq ! cloud liquid water index + + +!============================================================================== +contains +!============================================================================== + +subroutine oldcloud_init() + + use constituents, only: cnst_get_ind + + integer :: err + + iciwp_idx = pbuf_get_index('ICIWP',errcode=err) + iclwp_idx = pbuf_get_index('ICLWP',errcode=err) + cld_idx = pbuf_get_index('CLD') + rel_idx = pbuf_get_index('REL') + rei_idx = pbuf_get_index('REI') + + ! old optics + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('CLDLIQ', ixcldliq) + + return + +end subroutine oldcloud_init + +!============================================================================== +! Private methods +!============================================================================== + +subroutine old_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp) + + use physconst, only: gravit + + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + logical, intent(in) :: oldliqwp + + real(r8), pointer, dimension(:,:) :: rel + real(r8), pointer, dimension(:,:) :: cldn + real(r8), pointer, dimension(:,:) :: tmpptr + real(r8), dimension(pcols,pver) :: cliqwp + real(r8), dimension(nswbands) :: wavmin + real(r8), dimension(nswbands) :: wavmax + + ! Minimum cloud amount (as a fraction of the grid-box area) to + ! distinguish from clear sky + real(r8), parameter :: cldmin = 1.0e-80_r8 + + ! Decimal precision of cloud amount (0 -> preserve full resolution; + ! 10^-n -> preserve n digits of cloud amount) + real(r8), parameter :: cldeps = 0.0_r8 + + ! A. Slingo's data for cloud particle radiative properties (from 'A GCM + ! Parameterization for the Shortwave Properties of Water Clouds' JAS + ! vol. 46 may 1989 pp 1419-1427) + real(r8) :: abarl(4) = & ! A coefficient for extinction optical depth + (/ 2.817e-02_r8, 2.682e-02_r8,2.264e-02_r8,1.281e-02_r8/) + real(r8) :: bbarl(4) = & ! B coefficient for extinction optical depth + (/ 1.305_r8 , 1.346_r8 ,1.454_r8 ,1.641_r8 /) + real(r8) :: cbarl(4) = & ! C coefficient for single scat albedo + (/-5.62e-08_r8 ,-6.94e-06_r8 ,4.64e-04_r8 ,0.201_r8 /) + real(r8) :: dbarl(4) = & ! D coefficient for single scat albedo + (/ 1.63e-07_r8 , 2.35e-05_r8 ,1.24e-03_r8 ,7.56e-03_r8 /) + real(r8) :: ebarl(4) = & ! E coefficient for asymmetry parameter + (/ 0.829_r8 , 0.794_r8 ,0.754_r8 ,0.826_r8 /) + real(r8) :: fbarl(4) = & ! F coefficient for asymmetry parameter + (/ 2.482e-03_r8, 4.226e-03_r8,6.560e-03_r8,4.353e-03_r8/) + + real(r8) :: abarli ! A coefficient for current spectral band + real(r8) :: bbarli ! B coefficient for current spectral band + real(r8) :: cbarli ! C coefficient for current spectral band + real(r8) :: dbarli ! D coefficient for current spectral band + real(r8) :: ebarli ! E coefficient for current spectral band + real(r8) :: fbarli ! F coefficient for current spectral band + + ! Caution... A. Slingo recommends no less than 4.0 micro-meters nor + ! greater than 20 micro-meters + + integer :: ns, i, k, indxsl, Nday + integer :: lchnk, itim_old + real(r8) :: tmp1l, tmp2l, tmp3l, g + real(r8) :: kext(pcols,pver) + real(r8), pointer, dimension(:,:) :: iclwpth + + Nday = state%ncol + lchnk = state%lchnk + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, cld_idx,cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, rel_idx,rel) + + if (oldliqwp) then + do k=1,pver + do i = 1,Nday + cliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/(gravit*max(0.01_r8,cldn(i,k))) + end do + end do + else + if (iclwp_idx<0) then + call endrun('old_liquid_optics_sw: oldliqwp must be set to true since ICLWP was not found in pbuf') + endif + ! The following is the eventual target specification for in cloud liquid water path. + call pbuf_get_field(pbuf, iclwp_idx, tmpptr) + cliqwp = tmpptr + endif + + call get_sw_spectral_boundaries(wavmin,wavmax,'microns') + + do ns = 1, nswbands + ! Set index for cloud particle properties based on the wavelength, + ! according to A. Slingo (1989) equations 1-3: + ! Use index 1 (0.25 to 0.69 micrometers) for visible + ! Use index 2 (0.69 - 1.19 micrometers) for near-infrared + ! Use index 3 (1.19 to 2.38 micrometers) for near-infrared + ! Use index 4 (2.38 to 4.00 micrometers) for near-infrared + if(wavmax(ns) <= 0.7_r8) then + indxsl = 1 + else if(wavmax(ns) <= 1.25_r8) then + indxsl = 2 + else if(wavmax(ns) <= 2.38_r8) then + indxsl = 3 + else if(wavmin(ns) > 2.38_r8) then + indxsl = 4 + end if + + ! Set cloud extinction optical depth, single scatter albedo, + ! asymmetry parameter, and forward scattered fraction: + abarli = abarl(indxsl) + bbarli = bbarl(indxsl) + cbarli = cbarl(indxsl) + dbarli = dbarl(indxsl) + ebarli = ebarl(indxsl) + fbarli = fbarl(indxsl) + + do k=1,pver + do i=1,Nday + + ! note that optical properties for liquid valid only + ! in range of 4.2 > rel > 16 micron (Slingo 89) + if (cldn(i,k) >= cldmin .and. cldn(i,k) >= cldeps) then + tmp1l = abarli + bbarli/min(max(4.2_r8,rel(i,k)),16._r8) + liq_tau(ns,i,k) = 1000._r8*cliqwp(i,k)*tmp1l + else + liq_tau(ns,i,k) = 0.0_r8 + endif + + tmp2l = 1._r8 - cbarli - dbarli*min(max(4.2_r8,rel(i,k)),16._r8) + tmp3l = fbarli*min(max(4.2_r8,rel(i,k)),16._r8) + ! Do not let single scatter albedo be 1. Delta-eddington solution + ! for non-conservative case has different analytic form from solution + ! for conservative case, and raddedmx is written for non-conservative case. + liq_tau_w(ns,i,k) = liq_tau(ns,i,k) * min(tmp2l,.999999_r8) + g = ebarli + tmp3l + liq_tau_w_g(ns,i,k) = liq_tau_w(ns,i,k) * g + liq_tau_w_f(ns,i,k) = liq_tau_w(ns,i,k) * g * g + + end do ! End do i=1,Nday + end do ! End do k=1,pver + end do ! nswbands + + !call outfld('CL_OD_SW_OLD',liq_tau(idx_sw_diag,:,:), pcols, lchnk) + !call outfld('REL_OLD',rel(:,:), pcols, lchnk) + !call outfld('CLWPTH_OLD',cliqwp(:,:), pcols, lchnk) + !call outfld('KEXT_OLD',kext(:,:), pcols, lchnk) + + +end subroutine old_liquid_optics_sw +!============================================================================== + +subroutine old_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp) + + use physconst, only: gravit + + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + logical, intent(in) :: oldicewp + + real(r8), pointer, dimension(:,:) :: rei + real(r8), pointer, dimension(:,:) :: cldn + real(r8), pointer, dimension(:,:) :: tmpptr + real(r8), dimension(pcols,pver) :: cicewp + real(r8), dimension(nswbands) :: wavmin + real(r8), dimension(nswbands) :: wavmax + ! + ! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836) + real(r8) :: abari(4) = & ! a coefficient for extinction optical depth + (/ 3.448e-03_r8, 3.448e-03_r8,3.448e-03_r8,3.448e-03_r8/) + real(r8) :: bbari(4) = & ! b coefficient for extinction optical depth + (/ 2.431_r8 , 2.431_r8 ,2.431_r8 ,2.431_r8 /) + real(r8) :: cbari(4) = & ! c coefficient for single scat albedo + (/ 1.00e-05_r8 , 1.10e-04_r8 ,1.861e-02_r8,.46658_r8 /) + real(r8) :: dbari(4) = & ! d coefficient for single scat albedo + (/ 0.0_r8 , 1.405e-05_r8,8.328e-04_r8,2.05e-05_r8 /) + real(r8) :: ebari(4) = & ! e coefficient for asymmetry parameter + (/ 0.7661_r8 , 0.7730_r8 ,0.794_r8 ,0.9595_r8 /) + real(r8) :: fbari(4) = & ! f coefficient for asymmetry parameter + (/ 5.851e-04_r8, 5.665e-04_r8,7.267e-04_r8,1.076e-04_r8/) + + real(r8) :: abarii ! A coefficient for current spectral band + real(r8) :: bbarii ! B coefficient for current spectral band + real(r8) :: cbarii ! C coefficient for current spectral band + real(r8) :: dbarii ! D coefficient for current spectral band + real(r8) :: ebarii ! E coefficient for current spectral band + real(r8) :: fbarii ! F coefficient for current spectral band + + ! Minimum cloud amount (as a fraction of the grid-box area) to + ! distinguish from clear sky + real(r8), parameter :: cldmin = 1.0e-80_r8 + + ! Decimal precision of cloud amount (0 -> preserve full resolution; + ! 10^-n -> preserve n digits of cloud amount) + real(r8), parameter :: cldeps = 0.0_r8 + + integer :: ns, i, k, indxsl, lchnk, Nday + integer :: itim_old + real(r8) :: tmp1i, tmp2i, tmp3i, g + + Nday = state%ncol + lchnk = state%lchnk + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, cld_idx,cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, rei_idx,rei) + + if(oldicewp) then + do k=1,pver + do i = 1,Nday + cicewp(i,k) = 1000.0_r8*state%q(i,k,ixcldice)*state%pdel(i,k) /(gravit* max(0.01_r8,cldn(i,k))) + end do + end do + else + if (iciwp_idx<=0) then + call endrun('old_ice_optics_sw: oldicewp must be set to true since ICIWP was not found in pbuf') + endif + call pbuf_get_field(pbuf, iciwp_idx, tmpptr) + cicewp(1:pcols,1:pver) = 1000.0_r8*tmpptr + endif + + call get_sw_spectral_boundaries(wavmin,wavmax,'microns') + + do ns = 1, nswbands + + if(wavmax(ns) <= 0.7_r8) then + indxsl = 1 + else if(wavmax(ns) <= 1.25_r8) then + indxsl = 2 + else if(wavmax(ns) <= 2.38_r8) then + indxsl = 3 + else if(wavmin(ns) > 2.38_r8) then + indxsl = 4 + end if + + abarii = abari(indxsl) + bbarii = bbari(indxsl) + cbarii = cbari(indxsl) + dbarii = dbari(indxsl) + ebarii = ebari(indxsl) + fbarii = fbari(indxsl) + + do k=1,pver + do i=1,Nday + + ! note that optical properties for ice valid only + ! in range of 13 > rei > 130 micron (Ebert and Curry 92) + if (cldn(i,k) >= cldmin .and. cldn(i,k) >= cldeps) then + tmp1i = abarii + bbarii/max(13._r8,min(scalefactor*rei(i,k),130._r8)) + ice_tau(ns,i,k) = cicewp(i,k)*tmp1i + else + ice_tau(ns,i,k) = 0.0_r8 + endif + + tmp2i = 1._r8 - cbarii - dbarii*min(max(13._r8,scalefactor*rei(i,k)),130._r8) + tmp3i = fbarii*min(max(13._r8,scalefactor*rei(i,k)),130._r8) + ! Do not let single scatter albedo be 1. Delta-eddington solution + ! for non-conservative case has different analytic form from solution + ! for conservative case, and raddedmx is written for non-conservative case. + ice_tau_w(ns,i,k) = ice_tau(ns,i,k) * min(tmp2i,.999999_r8) + g = ebarii + tmp3i + ice_tau_w_g(ns,i,k) = ice_tau_w(ns,i,k) * g + ice_tau_w_f(ns,i,k) = ice_tau_w(ns,i,k) * g * g + + end do ! End do i=1,Nday + end do ! End do k=1,pver + end do ! nswbands + +end subroutine old_ice_optics_sw +!============================================================================== + +subroutine oldcloud_lw(state,pbuf,cld_abs_od,oldwp) + use physconst, only: gravit + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer + logical,intent(in) :: oldwp ! use old definition of waterpath + + + real(r8) :: gicewp(pcols,pver) + real(r8) :: gliqwp(pcols,pver) + real(r8) :: cicewp(pcols,pver) + real(r8) :: cliqwp(pcols,pver) + real(r8) :: ficemr(pcols,pver) + real(r8) :: cwp(pcols,pver) + real(r8) :: cldtau(pcols,pver) + + real(r8), pointer, dimension(:,:) :: cldn + real(r8), pointer, dimension(:,:) :: rei + 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) + + + + ncol = state%ncol + lchnk = state%lchnk + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, rei_idx, rei) + call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + if (oldwp) then + do k=1,pver + do i = 1,ncol + gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path. + gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path. + cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. + cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. + ficemr(i,k) = state%q(i,k,ixcldice) / & + max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq))) + end do + end do + cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) + else + if (iclwp_idx<=0 .or. iciwp_idx<=0) then + call endrun('oldcloud_lw: oldwp must be set to true since ICIWP and/or ICLWP were not found in pbuf') + endif + call pbuf_get_field(pbuf, iclwp_idx, iclwpth) + call pbuf_get_field(pbuf, iciwp_idx, iciwpth) + do k=1,pver + do i = 1,ncol + cwp(i,k) = 1000.0_r8 *iclwpth(i,k) + 1000.0_r8 *iciwpth(i, k) + ficemr(i,k) = 1000.0_r8 * iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k))) + end do + end do + endif + + do k=1,pver + do i=1,ncol + + !note that optical properties for ice valid only + !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 + cld_abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver) + enddo + +end subroutine oldcloud_lw + +!============================================================================== +subroutine old_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp) + use physconst, only: gravit + + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) + logical, intent(in) :: oldliqwp + + real(r8) :: gicewp(pcols,pver) + real(r8) :: gliqwp(pcols,pver) + real(r8) :: cicewp(pcols,pver) + real(r8) :: cliqwp(pcols,pver) + real(r8) :: ficemr(pcols,pver) + real(r8) :: cwp(pcols,pver) + real(r8) :: cldtau(pcols,pver) + + real(r8), pointer, dimension(:,:) :: cldn + 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), pointer, dimension(:,:) :: iclwpth, iciwpth + + ncol=state%ncol + lchnk = state%lchnk + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, rei_idx, rei) + call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + if (oldliqwp) then + do k=1,pver + do i = 1,ncol + gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path. + gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path. + cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. + cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. + ficemr(i,k) = state%q(i,k,ixcldice) / & + max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq))) + end do + end do + cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) + else + if (iclwp_idx<=0 .or. iciwp_idx<=0) then + call endrun('old_liq_get_rad_props_lw: oldliqwp must be set to true since ICIWP and/or ICLWP were not found in pbuf') + endif + call pbuf_get_field(pbuf, iclwp_idx, iclwpth) + call pbuf_get_field(pbuf, iciwp_idx, iciwpth) + do k=1,pver + do i = 1,ncol + cwp(i,k) = 1000.0_r8 *iclwpth(i,k) + 1000.0_r8 *iciwpth(i, k) + ficemr(i,k) = 1000.0_r8 * iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k))) + end do + end do + endif + + + do k=1,pver + do i=1,ncol + + ! Note from Andrew Conley: + ! Optics for RK no longer supported, This is constructed to get + ! close to bit for bit. Otherwise we could simply use liquid water path + !note that optical properties for ice valid only + !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 + + +end subroutine old_liq_get_rad_props_lw +!============================================================================== + +subroutine old_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp) + use physconst, only: gravit + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) + logical, intent(in) :: oldicewp + + real(r8) :: gicewp(pcols,pver) + real(r8) :: gliqwp(pcols,pver) + real(r8) :: cicewp(pcols,pver) + real(r8) :: cliqwp(pcols,pver) + real(r8) :: ficemr(pcols,pver) + real(r8) :: cwp(pcols,pver) + real(r8) :: cldtau(pcols,pver) + + real(r8), pointer, dimension(:,:) :: cldn + 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), pointer, dimension(:,:) :: iclwpth, iciwpth + + + ncol = state%ncol + lchnk = state%lchnk + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, rei_idx, rei) + call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + if(oldicewp) then + do k=1,pver + do i = 1,ncol + gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path. + gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path. + cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. + cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. + ficemr(i,k) = state%q(i,k,ixcldice) / & + max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq))) + end do + end do + cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) + else + if (iclwp_idx<=0 .or. iciwp_idx<=0) then + call endrun('old_ice_get_rad_props_lw: oldicewp must be set to true since ICIWP and/or ICLWP were not found in pbuf') + endif + call pbuf_get_field(pbuf, iclwp_idx, iclwpth) + call pbuf_get_field(pbuf, iciwp_idx, iciwpth) + do k=1,pver + do i = 1,ncol + cwp(i,k) = 1000.0_r8 *iciwpth(i,k) + 1000.0_r8 *iclwpth(i,k) + ficemr(i,k) = 1000.0_r8*iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k))) + end do + end do + endif + + do k=1,pver + do i=1,ncol + + ! Note from Andrew Conley: + ! Optics for RK no longer supported, This is constructed to get + ! close to bit for bit. Otherwise we could simply use ice water path + !note that optical properties for ice valid only + !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 + + !if(oldicewp) then + ! call outfld('CIWPTH_OLD',cicewp(:,:)/1000,pcols,lchnk) + !else + ! call outfld('CIWPTH_OLD',iciwpth(:,:),pcols,lchnk) + !endif + !call outfld('CI_OD_LW_OLD',cldtau(:,:),pcols,lchnk) + +end subroutine old_ice_get_rad_props_lw +!============================================================================== + +subroutine cloud_total_vis_diag_out(lchnk, nnite, idxnite, tau, radsuffix) + + ! output total aerosol optical depth for the visible band + + use cam_history, only: outfld + use cam_history_support, only : fillvalue + + integer, intent(in) :: lchnk + integer, intent(in) :: nnite ! number of night columns + integer, intent(in) :: idxnite(nnite) ! local column indices of night columns + real(r8), intent(in) :: tau(:,:) + character(len=*), intent(in) :: radsuffix ! identifies whether the radiation call + ! is for the climate calc or a diagnostic calc + + ! Local variables + integer :: i + real(r8) :: tmp(pcols) + !----------------------------------------------------------------------------- + + ! compute total aerosol optical depth output where only daylight columns + tmp(:) = sum(tau(:,:), 2) + do i = 1, nnite + tmp(idxnite(i)) = fillvalue + end do + !call outfld('cloudOD_v'//trim(radsuffix), tmp, pcols, lchnk) + +end subroutine cloud_total_vis_diag_out + +!============================================================================== + +end module oldcloud diff --git a/src/physics/rrtmgp/rad_solar_var.F90 b/src/physics/rrtmgp/rad_solar_var.F90 new file mode 100644 index 0000000000..82c6b120d3 --- /dev/null +++ b/src/physics/rrtmgp/rad_solar_var.F90 @@ -0,0 +1,148 @@ +!------------------------------------------------------------------------------- +! This module uses the Lean solar irradiance data to provide a solar cycle +! scaling factor used in heating rate calculations +!------------------------------------------------------------------------------- +module rad_solar_var + + use shr_kind_mod , only : r8 => shr_kind_r8 + use solar_irrad_data, only : sol_irrad, we, nbins, has_spectrum, sol_tsi + use solar_irrad_data, only : do_spctrl_scaling + use cam_abortutils, only : endrun + + implicit none + save + + private + public :: rad_solar_var_init + public :: get_variability + + real(r8), allocatable :: ref_band_irrad(:) ! scaling will be relative to ref_band_irrad in each band + real(r8), allocatable :: irrad(:) ! solar irradiance at model timestep in each band + real(r8) :: tsi_ref ! total solar irradiance assumed by RRTMGP + + real(r8), allocatable :: radbinmax(:) + real(r8), allocatable :: radbinmin(:) + integer :: nradbins + +!------------------------------------------------------------------------------- +contains +!------------------------------------------------------------------------------- + + subroutine rad_solar_var_init( ) + use radconstants, only : get_number_sw_bands + use radconstants, only : get_sw_spectral_boundaries + use radconstants, only : get_ref_solar_band_irrad + use radconstants, only : get_ref_total_solar_irrad + + integer :: i + integer :: ierr + integer :: yr, mon, tod + integer :: radmax_loc + + + call get_number_sw_bands(nradbins) + + if ( do_spctrl_scaling ) then + + if ( .not.has_spectrum ) then + call endrun('rad_solar_var_init: solar input file must have irradiance spectrum') + endif + + allocate (radbinmax(nradbins),stat=ierr) + if (ierr /= 0) then + call endrun('rad_solar_var_init: Error allocating space for radbinmax') + end if + + allocate (radbinmin(nradbins),stat=ierr) + if (ierr /= 0) then + call endrun('rad_solar_var_init: Error allocating space for radbinmin') + end if + + allocate (ref_band_irrad(nradbins), stat=ierr) + if (ierr /= 0) then + call endrun('rad_solar_var_init: Error allocating space for ref_band_irrad') + end if + + allocate (irrad(nradbins), stat=ierr) + if (ierr /= 0) then + call endrun('rad_solar_var_init: Error allocating space for irrad') + end if + + call get_sw_spectral_boundaries(radbinmin, radbinmax, 'nm') + + ! Make sure that the far-IR is included, even if RRTMG does not + ! extend that far down. 10^5 nm corresponds to a wavenumber of + ! 100 cm^-1. + radmax_loc = maxloc(radbinmax,1) + radbinmax(radmax_loc) = max(100000._r8,radbinmax(radmax_loc)) + + ! for rrtmg, reference spectrum from rrtmg + call get_ref_solar_band_irrad( ref_band_irrad ) + + else + + call get_ref_total_solar_irrad(tsi_ref) + + endif + + end subroutine rad_solar_var_init + +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- + subroutine get_variability( sfac ) + + real(r8), intent(out) :: sfac(nradbins) ! scaling factors for CAM heating + + integer :: yr, mon, day, tod + + if ( do_spctrl_scaling ) then + call integrate_spectrum( nbins, nradbins, we, radbinmin, radbinmax, sol_irrad, irrad) + sfac(:nradbins) = irrad(:nradbins)/ref_band_irrad(:nradbins) + else + sfac(:nradbins) = sol_tsi/tsi_ref + endif + + end subroutine get_variability + +!------------------------------------------------------------------------------- +! private method......... +!------------------------------------------------------------------------------- + + subroutine integrate_spectrum( nsrc, ntrg, src_x, min_trg, max_trg, src, trg ) + + use mo_util, only : rebin + + implicit none + + !--------------------------------------------------------------- + ! ... dummy arguments + !--------------------------------------------------------------- + integer, intent(in) :: nsrc ! dimension source array + integer, intent(in) :: ntrg ! dimension target array + real(r8), intent(in) :: src_x(nsrc+1) ! source coordinates + real(r8), intent(in) :: max_trg(ntrg) ! target coordinates + real(r8), intent(in) :: min_trg(ntrg) ! target coordinates + real(r8), intent(in) :: src(nsrc) ! source array + real(r8), intent(out) :: trg(ntrg) ! target array + + !--------------------------------------------------------------- + ! ... local variables + !--------------------------------------------------------------- + real(r8) :: trg_x(2), targ(1) ! target coordinates + integer :: i + + do i = 1, ntrg + + trg_x(1) = min_trg(i) + trg_x(2) = max_trg(i) + + call rebin( nsrc, 1, src_x, trg_x, src(1:nsrc), targ(:) ) + ! W/m2/nm --> W/m2 + trg( i ) = targ(1)*(trg_x(2)-trg_x(1)) + + enddo + + + end subroutine integrate_spectrum + +end module rad_solar_var diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 new file mode 100644 index 0000000000..1d1657fdc4 --- /dev/null +++ b/src/physics/rrtmgp/radconstants.F90 @@ -0,0 +1,427 @@ +module radconstants + +! This module contains constants that are specific to the radiative transfer +! code used in the RRTMGP model. + +! This comment from E3SM implementation, and is entirely relevant here: +! TODO: Should this data be handled in a more robust way? Much of this contains +! explicit mappings to indices, which would probably be better handled with get_ +! functions. I.e., get_nswbands() could query the kdist objects in case of +! RRTMGP, and the diag indices could look up the actual bands used in the kdist +! objects as well. On that note, this module should probably go away if +! possible in the future, and we should provide more robust access to the +! radiation interface. + + +use shr_kind_mod, only: r8 => shr_kind_r8 +use cam_abortutils, only: endrun + +implicit none +private +save + +! Number of bands in SW and LW (these will be set when RRTMGP initializes) +integer, public, protected :: nswbands = 14 +integer, public, protected :: nlwbands = 16 + +! Band limits (these get also get set at initialization) +real(r8), public, allocatable :: wavenumber_low_shortwave(:) +real(r8), public, allocatable :: wavenumber_high_shortwave(:) +real(r8), public, allocatable :: wavenumber_low_longwave(:) +real(r8), public, allocatable :: wavenumber_high_longwave(:) +! Reference irradiance per band +real(r8), public, allocatable :: solar_ref_band_irradiance(:) +real(r8), public, protected :: ref_tsi + +! SHORTWAVE DATA + + +! Wavenumbers of band boundaries +! +! Note: Currently rad_solar_var extends the lowest band down to +! 100 cm^-1 if it is too high to cover the far-IR. Any changes meant +! to affect IR solar variability should take note of this. + +! NOTE: these follow the non-monotonic ordering used for RRTMG +! - This is necessary because the optical properties files made for RRTMG use this order too. + +! NOTE: aside from order, as noted, these values match the ones in +! RRTMGP coefficients files. But I think we should be *setting* these +! values based on what is in that file, rather than hard-coding it here. + +! BPM: comment this data structure --> set it from radiation_init +! real(r8),parameter :: wavenumber_low_shortwave(nswbands) = & ! in cm^-1 +! (/2600._r8, 3250._r8, 4000._r8, 4650._r8, 5150._r8, 6150._r8, 7700._r8, & +! 8050._r8,12850._r8,16000._r8,22650._r8,29000._r8,38000._r8, 820._r8/) +! real(r8),parameter :: wavenumber_high_shortwave(nswbands) = & ! in cm^-1 +! (/3250._r8, 4000._r8, 4650._r8, 5150._r8, 6150._r8, 7700._r8, 8050._r8, & +! 12850._r8,16000._r8,22650._r8,29000._r8,38000._r8,50000._r8, 2600._r8/) + +! Mapping from RRTMG shortwave bands to RRTMGP +integer, parameter, dimension(14), public :: rrtmg_to_rrtmgp_swbands = & + (/ & + 14, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13 & + /) + +! BPM <-- commented this block. Replaced by allocatable, get values by calling set_irrad_by_band --> +! Solar irradiance at 1 A.U. in W/m^2 assumed by radiation code +! Rescaled so that sum is precisely 1368.22 and fractional amounts sum to 1.0 +! real(r8), parameter :: solar_ref_band_irradiance(nswbands) = & +! (/ & +! 12.11_r8, 20.3600000000001_r8, 23.73_r8, & +! 22.43_r8, 55.63_r8, 102.93_r8, 24.29_r8, & +! 345.74_r8, 218.19_r8, 347.20_r8, & +! 129.49_r8, 50.15_r8, 3.08_r8, 12.89_r8 & +! /) + +! These are indices to the band for diagnostic output +! CHANGE: rather than make these parameters, provide subroutines that set them +! using the function get_band_index_by_value (which should be called on initializing radiation) +! integer, parameter, public :: idx_sw_diag = 10 ! index to sw visible band (441 - 625 nm) +! integer, parameter, public :: idx_nir_diag = 8 ! index to sw near infrared (778-1240 nm) band +! integer, parameter, public :: idx_uv_diag = 11 ! index to sw uv (345-441 nm) band + +! integer, parameter, public :: rrtmg_sw_cloudsim_band = 9 ! rrtmgp band for .67 micron +! integer, parameter, public :: rrtmgp_sw_cloudsim_band = 10 ! b/c one band moves to beginning + +integer, public :: idx_sw_diag ! index to sw visible band (441 - 625 nm) +integer, public :: idx_nir_diag! index to sw near infrared (778-1240 nm) band +integer, public :: idx_uv_diag ! index to sw uv (345-441 nm) band + +! CHANGE: instead of setting rrtmg[p]_sw_cloudsim_band in radconstants, just make it in radiation +! rrtmgp_sw_cloudsim_band = get_band_index_by_value('sw', 0.67_r8, 'micron') ! rrtmgp band for .67 micron +! same for lw: +! rrtmgp_lw_cloudsim_band = get_band_index_by_value('lw', 10.5_r8, 'micron') + +! Number of evenly spaced intervals in rh +! The globality of this mesh may not be necessary +! Perhaps it could be specific to the aerosol +! But it is difficult to see how refined it must be +! for lookup. This value was found to be sufficient +! for Sulfate and probably necessary to resolve the +! high variation near rh = 1. Alternative methods +! were found to be too slow. +! Optimal approach would be for cam to specify size of aerosol +! based on each aerosol's characteristics. Radiation +! should know nothing about hygroscopic growth! +integer, parameter, public :: nrh = 1000 + +! LONGWAVE DATA + +! These are indices to the band for diagnostic output (see comment above about change) +! integer, parameter, public :: idx_lw_diag = 7 ! index to (H20 window) LW band +integer, public :: idx_lw_diag + + +! These are commented, and intended to be replaced by reading the RRTMGP optics object +! real(r8), parameter :: wavenumber_low_longwave(nlwbands) = &! Longwave spectral band limits (cm-1) +! (/ 10._r8, 350._r8, 500._r8, 630._r8, 700._r8, 820._r8, 980._r8, 1080._r8, & +! 1180._r8, 1390._r8, 1480._r8, 1800._r8, 2080._r8, 2250._r8, 2380._r8, 2600._r8 /) + +! real(r8), parameter :: wavenumber_high_longwave(nlwbands) = &! Longwave spectral band limits (cm-1) +! (/ 350._r8, 500._r8, 630._r8, 700._r8, 820._r8, 980._r8, 1080._r8, 1180._r8, & +! 1390._r8, 1480._r8, 1800._r8, 2080._r8, 2250._r8, 2380._r8, 2600._r8, 3250._r8 /) + +! GASES TREATED BY RADIATION (line spectrae) +integer, public, parameter :: gasnamelength = 5 +integer, public, parameter :: nradgas = 8 +character(len=gasnamelength), public, parameter :: gaslist(nradgas) & + = (/'H2O ','O3 ', 'O2 ', 'CO2 ', 'N2O ', 'CH4 ', 'CFC11', 'CFC12'/) + +! what is the minimum mass mixing ratio that can be supported by radiation implementation? +real(r8), public, parameter :: minmmr(nradgas) & + = epsilon(1._r8) + +! Length of "optics type" string specified in optics files. +integer, parameter, public :: ot_length = 32 + +public :: rad_gas_index + +public :: get_number_sw_bands, & + get_sw_spectral_boundaries, & + get_lw_spectral_boundaries, & + get_ref_solar_band_irrad, & + get_ref_total_solar_irrad, & + ! get_solar_band_fraction_irrad, & + get_idx_sw_diag, & + get_idx_nir_diag, & + get_idx_uv_diag, & + get_idx_lw_diag, & + get_band_index_by_value, & + set_wavenumber_bands,& + get_number_lw_bands, & + set_number_lw_bands, & + set_number_sw_bands, & + set_irrad_by_band, & + set_reference_tsi + +contains +!------------------------------------------------------------------------------ + ! COMMENT -- THIS CODE IS NOT USED. + ! subroutine get_solar_band_fraction_irrad(fractional_irradiance) + ! ! provide Solar Irradiance for each band in RRTMG + + ! ! fraction of solar irradiance in each band + ! real(r8), intent(out) :: fractional_irradiance(1:nswbands) + ! real(r8) :: tsi ! total solar irradiance + + ! tsi = sum(solar_ref_band_irradiance) + ! fractional_irradiance = solar_ref_band_irradiance / tsi + + ! end subroutine get_solar_band_fraction_irrad +!------------------------------------------------------------------------------ +subroutine get_ref_total_solar_irrad(tsi) + ! provide Total Solar Irradiance assumed by RRTMGP + + real(r8), intent(out) :: tsi + + ! tsi = sum(solar_ref_band_irradiance) + tsi = ref_tsi + +end subroutine get_ref_total_solar_irrad +!------------------------------------------------------------------------------ +subroutine set_reference_tsi(tsi) + ! set ref_tsi to provide total solar irradiance + ! this usually comes from reading a file + ! provided by the radiation scheme developers + real(r8), intent(in) :: tsi + ref_tsi = tsi +end subroutine set_reference_tsi +!------------------------------------------------------------------------------ +subroutine get_ref_solar_band_irrad( band_irrad ) + ! note: this shouldn't be used. + ! Instead, just use radconstants, only: solar_ref_band_irradiance + ! to access the data directly + ! solar irradiance in each band (W/m^2) + real(r8), intent(out) :: band_irrad(nswbands) + + if (allocated(solar_ref_band_irradiance)) then + band_irrad = solar_ref_band_irradiance + else + ! what to do + end if + +end subroutine get_ref_solar_band_irrad +!------------------------------------------------------------------------------ +subroutine get_number_sw_bands(number_of_bands) + + ! number of solar (shortwave) bands + integer, intent(out) :: number_of_bands + + number_of_bands = nswbands + +end subroutine get_number_sw_bands +!------------------------------------------------------------------------------ +subroutine set_number_sw_bands(number_of_bands) + ! set module data nswbands + ! expect: number_of_bands provided from RRTMGP optical properties object + integer, intent(in) :: number_of_bands + nswbands = number_of_bands +end subroutine set_number_sw_bands +!------------------------------------------------------------------------------ +subroutine get_number_lw_bands(number_of_bands) + + ! number of longwave bands + integer, intent(out) :: number_of_bands + + number_of_bands = nlwbands + +end subroutine get_number_lw_bands +!------------------------------------------------------------------------------ +subroutine set_number_lw_bands(number_of_bands) + ! set module data nlwbands + ! expect: number_of_bands provided from RRTMGP optical properties object + integer, intent(in) :: number_of_bands + nlwbands = number_of_bands +end subroutine set_number_lw_bands +!------------------------------------------------------------------------------ +subroutine set_wavenumber_bands(swlw, nbands, values) + ! set the low and high limits of the wavenumber grid for sw or lw + ! expect that values comes from RRTMGP method get_band_lims_wavenumber + character(*), intent(in) :: swlw ! which set of bands to set ['sw', 'lw'] + integer, intent(in) :: nbands + real(r8), intent(in) :: values(2,nbands) + select case(swlw) + case ('sw') + allocate(wavenumber_low_shortwave(nbands)) + allocate(wavenumber_high_shortwave(nbands)) + wavenumber_low_shortwave = values(1,:) + wavenumber_high_shortwave = values(2,:) + case ('lw') + allocate(wavenumber_low_longwave(nbands)) + allocate(wavenumber_high_longwave(nbands)) + wavenumber_low_longwave = values(1,:) + wavenumber_high_longwave = values(2,:) + end select +end subroutine set_wavenumber_bands +!------------------------------------------------------------------------------ +subroutine get_lw_spectral_boundaries(low_boundaries, high_boundaries, units) + ! provide spectral boundaries of each longwave band + + real(r8), intent(out) :: low_boundaries(nlwbands), high_boundaries(nlwbands) + character(*), intent(in) :: units ! requested units + + select case (units) + case ('inv_cm','cm^-1','cm-1') + low_boundaries = wavenumber_low_longwave + high_boundaries = wavenumber_high_longwave + case('m','meter','meters') + low_boundaries = 1.e-2_r8/wavenumber_high_longwave + high_boundaries = 1.e-2_r8/wavenumber_low_longwave + case('nm','nanometer','nanometers') + low_boundaries = 1.e7_r8/wavenumber_high_longwave + high_boundaries = 1.e7_r8/wavenumber_low_longwave + case('um','micrometer','micrometers','micron','microns') + low_boundaries = 1.e4_r8/wavenumber_high_longwave + high_boundaries = 1.e4_r8/wavenumber_low_longwave + case('cm','centimeter','centimeters') + low_boundaries = 1._r8/wavenumber_high_longwave + high_boundaries = 1._r8/wavenumber_low_longwave + case default + call endrun('get_lw_spectral_boundaries: spectral units not acceptable'//units) + end select + +end subroutine get_lw_spectral_boundaries + +!------------------------------------------------------------------------------ +subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) + ! provide spectral boundaries of each shortwave band + + real(r8), intent(out) :: low_boundaries(nswbands), high_boundaries(nswbands) + character(*), intent(in) :: units ! requested units + + select case (units) + case ('inv_cm','cm^-1','cm-1') + low_boundaries = wavenumber_low_shortwave + high_boundaries = wavenumber_high_shortwave + case('m','meter','meters') + low_boundaries = 1.e-2_r8/wavenumber_high_shortwave + high_boundaries = 1.e-2_r8/wavenumber_low_shortwave + case('nm','nanometer','nanometers') + low_boundaries = 1.e7_r8/wavenumber_high_shortwave + high_boundaries = 1.e7_r8/wavenumber_low_shortwave + case('um','micrometer','micrometers','micron','microns') + low_boundaries = 1.e4_r8/wavenumber_high_shortwave + high_boundaries = 1.e4_r8/wavenumber_low_shortwave + case('cm','centimeter','centimeters') + low_boundaries = 1._r8/wavenumber_high_shortwave + high_boundaries = 1._r8/wavenumber_low_shortwave + case default + call endrun('rad_constants.F90: spectral units not acceptable'//units) + end select + +end subroutine get_sw_spectral_boundaries + +!------------------------------------------------------------------------------ +integer function rad_gas_index(gasname) + + ! return the index in the gaslist array of the specified gasname + + character(len=*),intent(in) :: gasname + integer :: igas + + rad_gas_index = -1 + do igas = 1, nradgas + if (trim(gaslist(igas)).eq.trim(gasname)) then + rad_gas_index = igas + return + endif + enddo + call endrun ("rad_gas_index: can not find gas with name "//gasname) +end function rad_gas_index +!------------------------------------------------------------------------------ +subroutine get_idx_sw_diag() + idx_sw_diag = get_band_index_by_value('sw', 500.0_r8, 'nm') +end subroutine + +subroutine get_idx_nir_diag() + idx_nir_diag = get_band_index_by_value('sw', 1000.0_r8, 'nm') +end subroutine + +subroutine get_idx_uv_diag() + idx_uv_diag = get_band_index_by_value('sw', 400._r8, 'nm') +end subroutine + +subroutine get_idx_lw_diag() + idx_lw_diag = get_band_index_by_value('lw', 1000.0_r8, 'cm^-1') + ! value chosen to match the band used in CESM1/CESM2 +end subroutine + +function get_band_index_by_value(swlw, targetvalue, units) result(ans) + character(len=*),intent(in) :: swlw ! sw or lw bands + real(r8),intent(in) :: targetvalue + character(len=*),intent(in) :: units ! units of targetvalue + integer :: ans + ! local + real(r8), allocatable, dimension(:) :: lowboundaries, highboundaries + real(r8) :: tgt + integer :: nbnds, i + + select case (swlw) + case ('sw','SW','shortwave') + nbnds = nswbands + allocate(lowboundaries(nbnds), highboundaries(nbnds)) + lowboundaries = wavenumber_low_shortwave + highboundaries = wavenumber_high_shortwave + case ('lw', 'LW', 'longwave') + nbnds = nlwbands + allocate(lowboundaries(nbnds), highboundaries(nbnds)) + lowboundaries = wavenumber_low_longwave + highboundaries = wavenumber_high_longwave + case default + call endrun('rad_constants.F90: get_band_index_by_value: type of bands not accepted '//swlw) + end select + ! band info is in cm^-1 but target value may be other units, + ! so convert targetvalue to cm^-1 + select case (units) + case ('inv_cm','cm^-1','cm-1') + tgt = targetvalue + case('m','meter','meters') + tgt = 1.0_r8 / (targetvalue * 1.e2_r8) + case('nm','nanometer','nanometers') + tgt = 1.0_r8 / (targetvalue * 1.e-7_r8) + case('um','micrometer','micrometers','micron','microns') + tgt = 1.0_r8 / (targetvalue * 1.e-4_r8) + case('cm','centimeter','centimeters') + tgt = 1._r8/targetvalue + case default + call endrun('rad_constants.F90: get_band_index_by_value: units not acceptable'//units) + end select + ! now just loop through the array + do i = 1,nbnds + if ((tgt > lowboundaries(i)) .and. (tgt <= highboundaries(i))) then + ans = i + exit + end if + end do + ! Do something if the answer is not found? +end function get_band_index_by_value + + +subroutine set_irrad_by_band(solar_source, g2b) + ! Sets the solar irradiance in each shortwave band by summing the irradiance from gpoints. + ! solar_source = kdist_sw%solar_source <-- private TRY solar_source = kdist_sw%solar_source_quiet + ! g2b = kdist_sw%get_gpoint_bands() + real(r8), intent(in) :: solar_source(:) ! size ngpoints: irradiance per gpoint + integer, intent(in) :: g2b(:) ! size ngpoints: mapping from gpoint to band + integer :: i + allocate(solar_ref_band_irradiance(nswbands)) + solar_ref_band_irradiance(:) = 0.0_r8 + do i = 1,size(g2b) + solar_ref_band_irradiance(g2b(i)) = solar_ref_band_irradiance(g2b(i)) + solar_source(i) + end do +end subroutine set_irrad_by_band + +function get_irrad_by_band(solar_source, g2b) result(ans) + real(r8) :: solar_source(:) + integer :: g2b(:) + real(r8), allocatable :: ans(:) + if (.not. allocated(solar_ref_band_irradiance)) then + call set_irrad_by_band(solar_source, g2b) + end if + allocate(ans(size(solar_ref_band_irradiance))) + ans = solar_ref_band_irradiance +end function get_irrad_by_band + + +end module radconstants diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 new file mode 100644 index 0000000000..c33a36101b --- /dev/null +++ b/src/physics/rrtmgp/radiation.F90 @@ -0,0 +1,3070 @@ +module radiation + +!--------------------------------------------------------------------------------- +! +! CAM interface to RRTMGP radiation parameterization. +! +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8, cl=>shr_kind_cl +use spmd_utils, only: masterproc +use shr_mem_mod, only: shr_mem_getusage +use ppgrid, only: pcols, pver, pverp, begchunk, endchunk +use ref_pres, only: pref_edge +use physics_types, only: physics_state, physics_ptend +use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx +use camsrfexch, only: cam_out_t, cam_in_t +use physconst, only: cappa, cpair, gravit + +use time_manager, only: get_nstep, is_first_restart_step, & + get_curr_calday, get_step_size + +use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, & + rad_cnst_get_info, & + rad_cnst_get_gas, & + rad_cnst_out, & + oldcldoptics, & + liqcldoptics, & + icecldoptics + +use radconstants, only: nswbands, nlwbands, & ! number of bands + idx_sw_diag, & ! indices for diagnostics + idx_nir_diag, & + idx_uv_diag, & + idx_lw_diag, & + get_idx_sw_diag, & ! sets the idx_*_diag in radconstants module + get_idx_nir_diag, & + get_idx_uv_diag, & + get_idx_lw_diag, & + rrtmg_to_rrtmgp_swbands, & ! maps bands between rrtmg and rrtmgp + get_band_index_by_value, & ! function that figures out band for a wavelength + gasnamelength, & + nradgas, & + gaslist + +use mo_gas_concentrations, only: ty_gas_concs +use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + +use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active +use cam_history_support, only: fillvalue + +use ioFileMod, only: getfil +use cam_pio_utils, only: cam_pio_openfile +use pio, only: file_desc_t, & + var_desc_t, & + pio_int, & + PIO_NOERR, & + PIO_INTERNAL_ERROR, & + pio_seterrorhandling, & + PIO_BCAST_ERROR, & + pio_inq_dimlen, & + pio_inq_dimid, & + pio_inq_varid, & + pio_def_var, & + pio_put_var, & + pio_get_var, & + pio_put_att, & + PIO_NOWRITE, & + pio_closefile + +use cam_abortutils, only: endrun +use error_messages, only: handle_err +use cam_logfile, only: iulog +use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs + +use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & + cospsimulator_intr_run, cosp_nradsteps + + +implicit none +private +save + +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 + radiation_write_restart, &! write variables to restart + radiation_read_restart, &! read variables from restart + radiation_tend, &! compute heating rates and fluxes + rad_out_t ! type for diagnostic outputs + +integer,public, allocatable :: cosp_cnt(:) ! counter for cosp +integer,public :: cosp_cnt_init = 0 !initial value for cosp counter +integer, public :: sw_cloudsim_band, lw_cloudsim_band ! radiation bands that COSP uses + +real(r8), public, protected :: nextsw_cday ! future radiation calday for surface models + +type rad_out_t + real(r8) :: solin(pcols) ! Solar incident flux + + real(r8) :: qrsc(pcols,pver) + + real(r8) :: flux_sw_net_top(pcols) ! net shortwave flux at top (FSNT) + + real(r8) :: fsnsc(pcols) ! Clear sky surface abs solar flux + real(r8) :: fsntc(pcols) ! Clear sky total column abs solar flux + real(r8) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux + + real(r8) :: fsntoa(pcols) ! Net solar flux at TOA + real(r8) :: fsntoac(pcols) ! Clear sky net solar flux at TOA + real(r8) :: fsutoa(pcols) ! upwelling solar flux at TOA + + real(r8) :: fsnirt(pcols) ! Near-IR flux absorbed at toa + real(r8) :: fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa + real(r8) :: fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns + + real(r8) :: fsn200(pcols) ! fns interpolated to 200 mb + real(r8) :: fsn200c(pcols) ! fcns interpolated to 200 mb + real(r8) :: fsnr(pcols) ! fns interpolated to tropopause + + real(r8) :: flux_sw_up(pcols,pverp) ! upward shortwave flux on interfaces + real(r8) :: flux_sw_clr_up(pcols,pverp) ! upward shortwave clearsky flux + 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_dn(pcols,pverp) ! downward flux + real(r8) :: flux_lw_clr_dn(pcols,pverp) ! downward clearsky flux + + real(r8) :: qrlc(pcols,pver) + + real(r8) :: flntc(pcols) ! Clear sky lw flux at model top + real(r8) :: flut(pcols) ! Upward flux at top of model + real(r8) :: flutc(pcols) ! Upward Clear Sky flux at top of model + real(r8) :: lwcf(pcols) ! longwave cloud forcing + + real(r8) :: fln200(pcols) ! net longwave flux interpolated to 200 mb + real(r8) :: fln200c(pcols) ! net clearsky longwave flux interpolated to 200 mb + real(r8) :: flnr(pcols) ! net longwave flux interpolated to tropopause + + real(r8) :: flnsc(pcols) ! Clear sky lw flux at srf (up-down) + real(r8) :: fldsc(pcols) ! Clear sky lw flux at srf (down) + + real(r8) :: tot_cld_vistau(pcols,pver) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: tot_icld_vistau(pcols,pver) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: liq_icld_vistau(pcols,pver) ! in-cld liq cloud optical depth (only during day, night = fillvalue) + real(r8) :: ice_icld_vistau(pcols,pver) ! in-cld ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: snow_icld_vistau(pcols,pver) ! snow in-cloud visible sw optical depth for output on history files + real(r8) :: grau_icld_vistau(pcols,pver) ! Graupel in-cloud visible sw optical depth for output on history files +end type rad_out_t + +! Control variables set via namelist +character(len=cl) :: coefs_lw_file ! filepath for lw coefficients +character(len=cl) :: coefs_sw_file ! filepath for sw coefficients + +integer :: iradsw = -1 ! freq. of shortwave radiation calc in time steps (positive) + ! or hours (negative). +integer :: iradlw = -1 ! frequency of longwave rad. calc. in time steps (positive) + ! or hours (negative). + +integer :: irad_always = 0 ! Specifies length of time in timesteps (positive) + ! or hours (negative) SW/LW radiation will be + ! run continuously from the start of an + ! initial or restart run +logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations +logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. +logical :: graupel_in_rad = .false. ! graupel in radiation code +logical :: use_rad_uniform_angle = .false. ! if true, use the namelist rad_uniform_angle for the coszrs calculation + +! Physics buffer indices +integer :: qrs_idx = 0 +integer :: qrl_idx = 0 +integer :: su_idx = 0 +integer :: sd_idx = 0 +integer :: lu_idx = 0 +integer :: ld_idx = 0 +integer :: fsds_idx = 0 +integer :: fsns_idx = 0 +integer :: fsnt_idx = 0 +integer :: flns_idx = 0 +integer :: flnt_idx = 0 +integer :: cldfsnow_idx = 0 +integer :: cld_idx = 0 +integer :: cldfgrau_idx = 0 + +character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) + +! averaging time interval for zenith angle +real(r8) :: dt_avg = 0._r8 +real(r8) :: rad_uniform_angle = -99._r8 + +! Number of layers in radiation calculations. +integer :: nlay + +! Indices for copying data between cam and rrtmgp arrays +! The code currently assumes the rrtmgp vertical index goes bottom to top, +! while CAM goes top-to-bottom ... +! Newer RRTMGP checks for host model order and adjusts, so a lot of the assumptions are unncessary. +integer :: ktopcamm ! cam index of top layer +integer :: ktopradm ! rrtmgp index of layer corresponding to ktopcamm +integer :: ktopcami ! cam index of top interface +integer :: ktopradi ! rrtmgp index of interface corresponding to ktopcami + +! LW coefficients +type(ty_gas_optics_rrtmgp) :: kdist_lw ! bpm changed here +integer :: ngpt_lw + +! SW coefficients +type(ty_gas_optics_rrtmgp) :: kdist_sw ! bpm changed here +integer :: ngpt_sw + +! data to go from bands to gpoints (bpm) +integer, allocatable :: band2gpt_sw(:,:) ! n[s,l]wbands come from radconstants for now +integer, allocatable :: band2gpt_lw(:,:) + + +! Gases to use in the radiative calculations. +! RRTMGP kdist initialization needs to know the names of the +! gases before these are available via the rad_cnst interface. +! TODO: Move this to namelist or somewhere appropriate. +! NOTE: This list is not the same as `gaslist` in radconstants; is that a problem? Implication for diagnostic calls? +! character(len=5), dimension(10) :: active_gases = (/ & +! 'H2O ', 'CO2 ', 'O3 ', 'N2O ', & +! 'CO ', 'CH4 ', 'O2 ', 'N2 ', & +! 'CFC11', 'CFC12' /) +! BPM: use radconstants to define the active gases: +character(len=gasnamelength), dimension(nradgas) :: active_gases = gaslist + +type(var_desc_t) :: cospcnt_desc ! cosp +type(var_desc_t) :: nextsw_cday_desc + +!=============================================================================== +contains +!=============================================================================== + + +subroutine radiation_readnl(nlfile) + + ! Read radiation_nl namelist group. + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical, & + mpi_character + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + integer :: dtime ! timestep size + character(len=*), parameter :: subroutine_name = 'radiation_readnl' + + character(len=cl) :: rrtmgp_coefs_lw_file, rrtmgp_coefs_sw_file + + + namelist /radiation_nl/ rrtmgp_coefs_lw_file, & + rrtmgp_coefs_sw_file, & + iradsw, & + iradlw, & + irad_always, & + use_rad_dt_cosz, & + spectralflux, & + use_rad_uniform_angle, & + rad_uniform_angle, & + graupel_in_rad + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'radiation_nl', status=ierr) + if (ierr == 0) then + read(unitn, radiation_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subroutine_name // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + ! Broadcast namelist variables + call mpi_bcast(rrtmgp_coefs_lw_file, cl, mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: rrtmgp_coefs_lw_file") + call mpi_bcast(rrtmgp_coefs_sw_file, cl, mpi_character, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: coefs_sw_file") + call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: iradsw") + call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: iradlw") + call mpi_bcast(irad_always, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: irad_always") + call mpi_bcast(use_rad_dt_cosz, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: use_rad_dt_cosz") + call mpi_bcast(spectralflux, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: spectralflux") + call mpi_bcast(use_rad_uniform_angle, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: use_rad_uniform_angle") + call mpi_bcast(rad_uniform_angle, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: rad_uniform_angle") + call mpi_bcast(graupel_in_rad, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: graupel_in_rad") + + if (use_rad_uniform_angle .and. rad_uniform_angle == -99._r8) then + call endrun(subroutine_name // ' ERROR - use_rad_uniform_angle is set to .true, but rad_uniform_angle is not set ') + end if + + + ! Set module data + coefs_lw_file = rrtmgp_coefs_lw_file + coefs_sw_file = rrtmgp_coefs_sw_file + + ! Convert iradsw, iradlw and irad_always from hours to timesteps if necessary + dtime = get_step_size() + if (iradsw < 0) iradsw = nint((-iradsw *3600._r8)/dtime) + if (iradlw < 0) iradlw = nint((-iradlw *3600._r8)/dtime) + if (irad_always < 0) irad_always = nint((-irad_always*3600._r8)/dtime) + + !----------------------------------------------------------------------- + ! Print runtime options to log. + !----------------------------------------------------------------------- + + if (masterproc) then + write(iulog,*) 'RRTMGP radiation scheme parameters:' + write(iulog,10) trim(coefs_lw_file), trim(coefs_sw_file), iradsw, iradlw, & + irad_always, use_rad_dt_cosz, spectralflux, graupel_in_rad + end if + +10 format(' LW coefficents file: ', a/, & + ' SW coefficents file: ', a/, & + ' Frequency (timesteps) of Shortwave Radiation calc: ',i5/, & + ' Frequency (timesteps) of Longwave Radiation calc: ',i5/, & + ' SW/LW calc done every timestep for first N steps. N=',i5/, & + ' Use average zenith angle: ',l5/, & + ' Output spectrally resolved fluxes: ',l5/, & + ' Graupel in Radiation Code: ',l5/) + +end subroutine radiation_readnl + +!================================================================================================ + +subroutine radiation_register + + ! Register radiation fields in the physics buffer + + use physics_buffer, only: pbuf_add_field, dtype_r8 + use radiation_data, only: rad_data_register + + call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate + call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate + + call pbuf_add_field('FSDS' , 'global',dtype_r8,(/pcols/), fsds_idx) ! Surface solar downward flux + call pbuf_add_field('FSNS' , 'global',dtype_r8,(/pcols/), fsns_idx) ! Surface net shortwave flux + call pbuf_add_field('FSNT' , 'global',dtype_r8,(/pcols/), fsnt_idx) ! Top-of-model net shortwave flux + + call pbuf_add_field('FLNS' , 'global',dtype_r8,(/pcols/), flns_idx) ! Surface net longwave flux + call pbuf_add_field('FLNT' , 'global',dtype_r8,(/pcols/), flnt_idx) ! Top-of-model net longwave flux + + ! If the namelist has been configured for preserving the spectral fluxes, then create + ! physics buffer variables to store the results. + if (spectralflux) then + call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) + call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) + call pbuf_add_field('LU' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), lu_idx) ! longwave upward flux (per band) + call pbuf_add_field('LD' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), ld_idx) ! longwave downward flux (per band) + end if + + call rad_data_register() ! if "fixed dynamical heating", this adds 4 fields to physics buffer (needed?) + +end subroutine radiation_register + +!================================================================================================ + +function radiation_do(op, timestep) + + ! Return true if the specified operation is done this timestep. + + character(len=*), intent(in) :: op ! name of operation + integer, intent(in), optional:: timestep + logical :: radiation_do ! return value + + ! Local variables + integer :: nstep ! current timestep number + !----------------------------------------------------------------------- + + if (present(timestep)) then + nstep = timestep + else + nstep = get_nstep() + end if + + select case (op) + case ('sw') ! do a shortwave heating calc this timestep? + radiation_do = nstep == 0 .or. iradsw == 1 & + .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + case ('lw') ! do a longwave heating calc this timestep? + radiation_do = nstep == 0 .or. iradlw == 1 & + .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + case default + call endrun('radiation_do: unknown operation:'//op) + end select +end function radiation_do + +!================================================================================================ + +real(r8) function radiation_nextsw_cday() + + ! Return calendar day of next sw radiation calculation + + ! Local variables + integer :: nstep ! timestep counter + logical :: dosw ! true => do shosrtwave calc + integer :: offset ! offset for calendar day calculation + integer :: dtime ! integer timestep size + real(r8):: calday ! calendar day of + real(r8):: caldayp1 ! calendar day of next time-step + + !----------------------------------------------------------------------- + + radiation_nextsw_cday = -1._r8 + dosw = .false. + nstep = get_nstep() + dtime = get_step_size() + offset = 0 + do while (.not. dosw) + nstep = nstep + 1 + offset = offset + dtime + if (radiation_do('sw', nstep)) then + radiation_nextsw_cday = get_curr_calday(offset=offset) + dosw = .true. + end if + end do + if(radiation_nextsw_cday == -1._r8) then + call endrun('error in radiation_nextsw_cday') + end if + + ! determine if next radiation time-step not equal to next time-step + if (get_nstep() >= 1) then + caldayp1 = get_curr_calday(offset=int(dtime)) + if (caldayp1 /= radiation_nextsw_cday) radiation_nextsw_cday = -1._r8 + end if + +end function radiation_nextsw_cday + +!================================================================================================ + +subroutine radiation_init(pbuf2d) + + ! Initialize the radiation, cloud, and aerosol optics, and solar variability + ! parameterizations. + ! Add fields to the history buffer. + + use physics_buffer, only: pbuf_get_index, pbuf_set_field + use phys_control, only: phys_getopts + use rad_solar_var, only: rad_solar_var_init ! This initializes total solar irradiance + use radiation_data, only: rad_data_init + use cloud_rad_props, only: cloud_rad_props_init + use modal_aer_opt, only: modal_aer_opt_init + use rrtmgp_inputs, only: rrtmgp_inputs_init + use time_manager, only: is_first_step + use radconstants, only: set_number_sw_bands, set_number_lw_bands, set_wavenumber_bands, set_irrad_by_band, set_reference_tsi + + ! arguments + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + ! local variables + character(len=128) :: errmsg + + ! names of gases that are available in the model + ! -- needed for the kdist initialization routines + type(ty_gas_concs) :: available_gases + + integer :: icall, nmodes + logical :: active_calls(0:N_DIAG) + integer :: nstep ! current timestep number + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_vdiag ! output the variables used by the AMWG variability diag package + logical :: history_budget ! output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + integer :: history_budget_histfile_num ! output history file number for budget fields + integer :: ierr + + integer :: dtime + real(r8) :: ref_tsi + + character(len=*), parameter :: sub = 'radiation_init' + !----------------------------------------------------------------------- + + ! + ! replacement of RRTMG's rrtmg_state_init + ! + + ! Number of layers in radiation calculation is capped by the number of + ! pressure interfaces below 1 Pa. When the entire model atmosphere is + ! below 1 Pa then an extra layer is added to the top of the model for + ! the purpose of the radiation calculation. + nlay = count( pref_edge(:) > 1._r8 ) ! pascals (0.01 mbar) + + ! Use k*rad* to access variables ON THE RADIATION GRID + ! Use k*cam* to access variables ON THE CAM GRID + if (nlay == pverp) then + ktopcamm = 1 ! interpretation: highest CAM grid layer at which radiation is active + ktopcami = 1 + ktopradm = nlay + 1 - pver ! radiation grid layer the corresponds to CAM's highest layer (expected to be 2) + ktopradi = nlay + 1 - pver + else ! nlay < pverp + ! nlay layers are set by radiation + ! nlay+1 interfaces are set by radiation + ktopcamm = pverp - nlay + 1 + ktopcami = pverp - nlay + 1 + ktopradm = 1 ! radiation grid index at top is just 1 + ktopradi = 1 + end if + ! bottom indices are known, so we don't need to have extra variables. + ! kbotcamm = pver + ! kbotcami = pverp + ! kbotradm = nlay + ! kbotradi = nlay + 1 + + call set_available_gases(active_gases, available_gases) ! gases needed to initialize spectral info + + call coefs_init(coefs_lw_file, kdist_lw, available_gases, band2gpt_lw) + call coefs_init(coefs_sw_file, kdist_sw, available_gases, band2gpt_sw, ref_tsi) ! bpm : these now provide band2gpt which should be global + call set_reference_tsi(ref_tsi) + + ! set number of sw/lw bands in radconstants + call set_number_sw_bands(kdist_sw%get_nband()) + call set_number_lw_bands(kdist_lw%get_nband()) + write(iulog, *) 'rad_init: NUMBER SW BANDS: ',kdist_sw%get_nband(),' NUMBER LW BANDS: ',kdist_lw%get_nband() + + ! set the sw/lw band limits in radconstants + call set_wavenumber_bands('sw', kdist_sw%get_nband(), kdist_sw%get_band_lims_wavenumber()) + call set_wavenumber_bands('lw', kdist_lw%get_nband(), kdist_lw%get_band_lims_wavenumber()) + + call rad_solar_var_init() ! sets the total solar irradiance (I wonder whether this should use kdist information instead of radconstants; alternative use kdist%set_tsi to ensure consistency?) + call rrtmgp_inputs_init(ktopcamm, ktopradm, ktopcami, ktopradi) ! this sets these values as module data in rrtmgp_inputs + + call rad_data_init(pbuf2d) ! initialize output fields for offline driver + call cloud_rad_props_init() + + ngpt_lw = kdist_lw%get_ngpt() ! these set global values + ngpt_sw = kdist_sw%get_ngpt() + + ! bpm: set the indices used for diagnostics using specific band: + call get_idx_sw_diag() ! index to sw visible band (441 - 625 nm) + call get_idx_nir_diag() ! index to sw near infrared (778-1240 nm) band + call get_idx_uv_diag() ! index to sw uv (345-441 nm) band + if (docosp) then + sw_cloudsim_band = get_band_index_by_value('sw', 0.67_r8, 'micron') ! rrtmgp band for .67 micron + lw_cloudsim_band = get_band_index_by_value('lw', 10.5_r8, 'micron') + end if + call get_idx_lw_diag() + + + if (is_first_step()) then + call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) + end if + + + ! Set the radiation timestep for cosz calculations if requested using + ! the adjusted iradsw value from radiation + if (use_rad_dt_cosz) then + dtime = get_step_size() + dt_avg = iradsw*dtime + end if + + ! Surface components to get radiation computed today + if (.not. is_first_restart_step()) then + nextsw_cday = get_curr_calday() + end if + + call phys_getopts(history_amwg_out = history_amwg, & + history_vdiag_out = history_vdiag, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num) + + ! Determine whether modal aerosols are affecting the climate, and if so + ! then initialize the modal aerosol optics module + call rad_cnst_get_info(0, nmodes=nmodes) + if (nmodes > 0) then + call modal_aer_opt_init() + end if + + ! "irad_always" is number of time steps to execute radiation + ! continuously from start of initial OR restart run + ! _This gets used in radiation_do_ + 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)) + if (is_first_restart_step()) then + cosp_cnt(begchunk:endchunk) = cosp_cnt_init + else + cosp_cnt(begchunk:endchunk) = 0 + end if + + + ! Add fields to history buffer + + call addfld('TOT_CLD_VISTAU', (/ 'lev' /), 'A', '1', & + 'Total gbx cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('TOT_ICLD_VISTAU', (/ 'lev' /), 'A', '1', & + 'Total in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('LIQ_ICLD_VISTAU', (/ 'lev' /), 'A', '1', & + 'Liquid in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('ICE_ICLD_VISTAU', (/ 'lev' /), 'A', '1', & + 'Ice in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + + + ! get list of active radiation calls + call rad_cnst_get_call_list(active_calls) + + ! Add shortwave radiation fields to history master field list. + + do icall = 0, N_DIAG + + if (active_calls(icall)) then + + call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar insolation', sampling_seq='rad_lwsw') + + call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Solar heating rate', sampling_seq='rad_lwsw') + call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky solar heating rate', & + sampling_seq='rad_lwsw') + call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Shortwave cloud forcing', & + sampling_seq='rad_lwsw') + call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') + + call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net shortwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net shortwave flux at 200 mb', & + sampling_seq='rad_lwsw') + + call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at tropopause', & + sampling_seq='rad_lwsw') + + call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared direct to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible direct to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared diffuse to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible diffuse to surface', & + sampling_seq='rad_lwsw') + call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at surface', & + sampling_seq='rad_lwsw') + + call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling solar flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky downwelling solar flux at surface', & + sampling_seq='rad_lwsw') + + call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave upward flux') + call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') + call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') + call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') + + if (history_amwg) then + call add_default('SOLIN'//diag(icall), 1, ' ') + call add_default('QRS'//diag(icall), 1, ' ') + call add_default('FSNT'//diag(icall), 1, ' ') + call add_default('FSNTC'//diag(icall), 1, ' ') + call add_default('FSNTOA'//diag(icall), 1, ' ') + call add_default('FSNTOAC'//diag(icall), 1, ' ') + call add_default('SWCF'//diag(icall), 1, ' ') + call add_default('FSNS'//diag(icall), 1, ' ') + call add_default('FSNSC'//diag(icall), 1, ' ') + call add_default('FSUTOA'//diag(icall), 1, ' ') + call add_default('FSDSC'//diag(icall), 1, ' ') + call add_default('FSDS'//diag(icall), 1, ' ') + endif + + end if + end do + + ! Add longwave radiation fields to history master field list. + + do icall = 0, N_DIAG + + if (active_calls(icall)) then + call addfld('QRL'//diag(icall), (/ 'lev' /), 'A', 'K/s', & + 'Longwave heating rate', sampling_seq='rad_lwsw') + call addfld('QRLC'//diag(icall), (/ 'lev' /), 'A', 'K/s', & + 'Clearsky longwave heating rate', sampling_seq='rad_lwsw') + call addfld('FLNT'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net longwave flux at top of model', sampling_seq='rad_lwsw') + call addfld('FLNTC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net longwave flux at top of model', sampling_seq='rad_lwsw') + call addfld('FLUT'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Upwelling longwave flux at top of model', sampling_seq='rad_lwsw') + call addfld('FLUTC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky upwelling longwave flux at top of model', sampling_seq='rad_lwsw') + call addfld('LWCF'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Longwave cloud forcing', sampling_seq='rad_lwsw') + call addfld('FLN200'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net longwave flux at 200 mb', sampling_seq='rad_lwsw') + call addfld('FLN200C'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net longwave flux at 200 mb', sampling_seq='rad_lwsw') + call addfld('FLNR'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net longwave flux at tropopause', sampling_seq='rad_lwsw') + call addfld('FLNS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net longwave flux at surface', sampling_seq='rad_lwsw') + call addfld('FLNSC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net longwave flux at surface', sampling_seq='rad_lwsw') + call addfld('FLDS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Downwelling longwave flux at surface', sampling_seq='rad_lwsw') + call addfld('FLDSC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky Downwelling longwave flux at surface', sampling_seq='rad_lwsw') + call addfld('FUL'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Longwave upward flux') + call addfld('FDL'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Longwave downward flux') + call addfld('FULC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Longwave clear-sky upward flux') + call addfld('FDLC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Longwave clear-sky downward flux') + + if (history_amwg) then + call add_default('QRL'//diag(icall), 1, ' ') + call add_default('FLNT'//diag(icall), 1, ' ') + call add_default('FLNTC'//diag(icall), 1, ' ') + call add_default('FLUT'//diag(icall), 1, ' ') + call add_default('FLUTC'//diag(icall), 1, ' ') + call add_default('LWCF'//diag(icall), 1, ' ') + call add_default('FLNS'//diag(icall), 1, ' ') + call add_default('FLNSC'//diag(icall), 1, ' ') + call add_default('FLDS'//diag(icall), 1, ' ') + end if + + end if + end do + + call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') ! COSP-related output + + ! NOTE: HIRS/MSU diagnostic brightness temperatures are removed. + + ! Heating rate needed for d(theta)/dt computation + call addfld ('HR',(/ 'lev' /), 'A','K/s','Heating rate needed for d(theta)/dt computation') + + if ( history_budget .and. history_budget_histfile_num > 1 ) then + call add_default ('QRL ', history_budget_histfile_num, ' ') + call add_default ('QRS ', history_budget_histfile_num, ' ') + end if + + if (history_vdiag) then + call add_default('FLUT', 2, ' ') + call add_default('FLUT', 3, ' ') + end if + + cld_idx = pbuf_get_index('CLD') + cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=ierr) + cldfgrau_idx = pbuf_get_index('CLDFGRAU',errcode=ierr) + if (cldfsnow_idx > 0) then + call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', & + 'Snow in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + end if + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + call addfld('GRAU_ICLD_VISTAU', (/ 'lev' /), 'A', '1', & + 'Graupel in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + endif + +end subroutine radiation_init + +!=============================================================================== + +subroutine radiation_define_restart(file) + + ! define variables to be written to restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + integer :: ierr + !---------------------------------------------------------------------------- + + call pio_seterrorhandling(file, PIO_BCAST_ERROR) + + ierr = pio_def_var(file, 'nextsw_cday', pio_int, nextsw_cday_desc) + ierr = pio_put_att(file, nextsw_cday_desc, 'long_name', 'future radiation calday for surface models') + if (docosp) then + ierr = pio_def_var(File, 'cosp_cnt_init', pio_int, cospcnt_desc) + end if + +end subroutine radiation_define_restart + +!=============================================================================== + +subroutine radiation_write_restart(file) + + ! write variables to restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + integer :: ierr + !---------------------------------------------------------------------------- + ierr = pio_put_var(File, nextsw_cday_desc, (/ nextsw_cday /)) + if (docosp) then + ierr = pio_put_var(File, cospcnt_desc, (/cosp_cnt(begchunk)/)) + end if + +end subroutine radiation_write_restart + +!=============================================================================== + +subroutine radiation_read_restart(file) + + ! read variables from restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + integer :: ierr + type(var_desc_t) :: vardesc + integer :: err_handling + + !---------------------------------------------------------------------------- + if (docosp) then + call pio_seterrorhandling(File, PIO_BCAST_ERROR, err_handling) + ierr = pio_inq_varid(File, 'cosp_cnt_init', vardesc) + call pio_seterrorhandling(File, err_handling) + if (ierr /= PIO_NOERR) then + cosp_cnt_init = 0 + else + ierr = pio_get_var(File, vardesc, cosp_cnt_init) + end if + end if + + ierr = pio_inq_varid(file, 'nextsw_cday', vardesc) + ierr = pio_get_var(file, vardesc, nextsw_cday) + + +end subroutine radiation_read_restart + +!=============================================================================== + +subroutine radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) + + !----------------------------------------------------------------------- + ! + ! Driver for radiation computation. + ! + !----------------------------------------------------------------------- + + ! Location/Orbital Parameters for cosine zenith angle + use phys_grid, only: get_rlat_all_p, get_rlon_all_p + use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr + use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz + + use mo_gas_concentrations, only: ty_gas_concs + use rrtmgp_inputs, only: rrtmgp_set_state, rrtmgp_set_gases_lw, rrtmgp_set_cloud_lw, & + rrtmgp_set_aer_lw, rrtmgp_set_gases_sw, rrtmgp_set_cloud_sw, & + rrtmgp_set_aer_sw + + use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw + + use cloud_rad_props, only: get_ice_optics_sw, ice_cloud_get_rad_props_lw, & + get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & + get_snow_optics_sw, snow_cloud_get_rad_props_lw, & + cloud_rad_props_get_lw, & + grau_cloud_get_rad_props_lw, & + get_grau_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 mo_optical_props, only: ty_optical_props, ty_optical_props_2str, ty_optical_props_1scl + + use mo_fluxes_byband, only: ty_fluxes_byband + + ! use mo_rrtmgp_clr_all_sky, only: rte_lw, rte_sw + use rrtmgp_driver, only: rte_lw, rte_sw + + use radheat, only: radheat_tend + + use radiation_data, only: rad_data_write + + use interpolate_data, only: vertinterp + use tropopause, only: tropopause_find, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE + use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps + + + ! Arguments + type(physics_state), intent(in), target :: state + type(physics_ptend), intent(out) :: ptend + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(in) :: cam_in + real(r8), intent(out) :: net_flx(pcols) + + type(rad_out_t), target, optional, intent(out) :: rd_out + + + ! Local variables + type(rad_out_t), pointer :: rd ! allow rd_out to be optional by allocating a local object + ! if the argument is not present + logical :: write_output + + integer :: i, k + integer :: lchnk, ncol + logical :: dosw, dolw + + real(r8) :: calday ! current calendar day + real(r8) :: delta ! Solar declination angle in radians + real(r8) :: eccf ! Earth orbit eccentricity factor + real(r8) :: clat(pcols) ! current latitudes(radians) + real(r8) :: clon(pcols) ! current longitudes(radians) + real(r8) :: coszrs(pcols) ! Cosine solar zenith angle + + ! Gathered indices of day and night columns + ! chunk_column_index = IdxDay(daylight_column_index) + integer :: Nday ! Number of daylight columns + integer :: Nnite ! Number of night columns + integer :: IdxDay(pcols) ! Indices of daylight columns -- Dimension is pcols, and is filled from beginning, so idxday(1:nday) are the indices of daylit columns. + integer :: IdxNite(pcols) ! Indices of night columns + + integer :: itim_old + + real(r8), pointer :: cld(:,:) ! cloud fraction + real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds"- whatever they are + real(r8), pointer :: cldfgrau(:,:) ! cloud fraction of just "graupel clouds"- whatever they are + real(r8), pointer :: qrs(:,:) => null() ! shortwave radiative heating rate + real(r8), pointer :: qrl(:,:) => null() ! longwave radiative heating rate + real(r8), pointer :: fsds(:) ! Surface solar down flux + real(r8), pointer :: fsns(:) ! Surface solar absorbed flux + real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top + real(r8), pointer :: flns(:) ! Srf longwave cooling (up-down) flux + real(r8), pointer :: flnt(:) ! Net outgoing lw flux at model top + + real(r8), pointer, dimension(:,:,:) :: su => NULL() ! shortwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: sd => NULL() ! shortwave spectral flux down + real(r8), pointer, dimension(:,:,:) :: lu => NULL() ! longwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: ld => NULL() ! longwave spectral flux down + + ! tropopause diagnostic + integer :: troplev(pcols) + real(r8) :: p_trop(pcols) + + ! state data passed to radiation calc + real(r8), allocatable :: t_sfc(:) + real(r8), allocatable :: emis_sfc(:,:) + real(r8), allocatable :: t_rad(:,:) + real(r8), allocatable :: pmid_rad(:,:) + real(r8), allocatable :: pint_rad(:,:) + real(r8), allocatable :: t_day(:,:) + real(r8), allocatable :: pmid_day(:,:) + real(r8), allocatable :: pint_day(:,:) + real(r8), allocatable :: coszrs_day(:) + real(r8), allocatable :: alb_dir(:,:) + real(r8), allocatable :: alb_dif(:,:) + real(r8) :: tsi + + + ! 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_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_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_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau + real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) + + ! "snow" 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_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w + real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) + + ! Add graupel as another snow species. + ! 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_f(nswbands,pcols,pver) ! graupel forward scattered fraction * tau * w + real(r8) :: grau_lw_abs (nlwbands,pcols,pver)! graupel absorption optics depth (LW) + + ! combined cloud radiative parameters are "in cloud" not "in cell" + 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_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) + + ! Aerosol radiative properties **N.B.** These are zero-indexed to be on RADIATION GRID (assumes "extra layer" is being added?) + 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_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau + real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + + ! RRTMGP cloud objects (McICA sampling of cloud optical properties) + type(ty_optical_props_1scl) :: cloud_lw + type(ty_optical_props_2str) :: cloud_sw + + ! Irradiance + integer :: icall ! index through climate/diagnostic radiation calls + logical :: active_calls(0:N_DIAG) + + ! gas vmr + type(ty_gas_concs) :: gas_concs_lw + type(ty_gas_concs) :: gas_concs_sw + ! RRTMGP aerosol objects + type(ty_optical_props_1scl) :: aer_lw + type(ty_optical_props_2str) :: aer_sw + + ! Fluxes + ! These are used locally only. SW fluxes are on day columns only. + ! "Output" (i.e. diagnostic) fluxes are provided with rd, fsns, fcns, fnl, fcnl, etc. + ! see set_sw_diags and radiation_output_sw and radiation_output_lw + type(ty_fluxes_byband) :: fsw, fswc + type(ty_fluxes_byband) :: flw, flwc + + real(r8) :: fns(pcols,pverp) ! net shortwave flux + real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux + real(r8) :: fnl(pcols,pverp) ! net longwave flux + real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux + + + real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity ! for COSP + real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau ! for COSP + real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth ! for COSP + + + real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables + + character(len=128) :: errmsg + + character(len=*), parameter :: sub = 'radiation_tend' + + logical :: conserve_energy = .false. ! Flag to carry (QRS,QRL)*dp across time steps. + + integer :: iband + integer :: nlevcam, nlevrad + real(r8) :: mem_hw_end, mem_hw_beg, mem_end, mem_beg, temp + + !-------------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + nlevcam = size(state%t,2) ! number of levels in CAM grid + + if (present(rd_out)) then + rd => rd_out + write_output = .false. + else + allocate(rd) + write_output = .true. + end if + + dosw = radiation_do('sw', get_nstep()) ! do shortwave heating calc this timestep? + dolw = radiation_do('lw', get_nstep()) ! do longwave heating calc this timestep? + + ! Cosine solar zenith angle for current time step + calday = get_curr_calday() + call get_rlat_all_p(lchnk, ncol, clat) + call get_rlon_all_p(lchnk, ncol, clon) + + call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, & + delta, eccf) + + if (use_rad_uniform_angle) then + do i = 1, ncol + coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, uniform_angle=rad_uniform_angle) + end do + else + do i = 1, ncol + coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg) ! if dt_avg /= 0, it triggers using avg coszrs + end do + end if + + ! Gather night/day column indices. + Nday = 0 + Nnite = 0 + do i = 1, ncol + if ( coszrs(i) > 0.0_r8 ) then + Nday = Nday + 1 + IdxDay(Nday) = i + else + Nnite = Nnite + 1 + IdxNite(Nnite) = i + end if + end do + + ! Associate pointers to physics buffer fields + itim_old = pbuf_old_tim_idx() + if (cldfsnow_idx > 0) then + call pbuf_get_field(pbuf, & + cldfsnow_idx, & + cldfsnow, & + start=(/1,1,itim_old/), & + kount=(/pcols,pver,1/) ) + end if + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + call pbuf_get_field(pbuf, cldfgrau_idx, cldfgrau, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + endif + + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, qrs_idx, qrs) + call pbuf_get_field(pbuf, qrl_idx, qrl) + + call pbuf_get_field(pbuf, fsns_idx, fsns) + call pbuf_get_field(pbuf, fsnt_idx, fsnt) + call pbuf_get_field(pbuf, fsds_idx, fsds) + call pbuf_get_field(pbuf, flns_idx, flns) + call pbuf_get_field(pbuf, flnt_idx, flnt) + + if (spectralflux) then + call pbuf_get_field(pbuf, su_idx, su) + call pbuf_get_field(pbuf, sd_idx, sd) + call pbuf_get_field(pbuf, lu_idx, lu) + call pbuf_get_field(pbuf, ld_idx, ld) + end if + + ! initialize (and reset) all the fluxes // sw fluxes only on nday columns + call initialize_rrtmgp_fluxes(nday, nlay+1, nswbands, fsw, do_direct=.true.) + call initialize_rrtmgp_fluxes(nday, nlay+1, nswbands, fswc, do_direct=.true.) + call initialize_rrtmgp_fluxes(ncol, nlay+1, nlwbands, flw) + call initialize_rrtmgp_fluxes(ncol, nlay+1, nlwbands, flwc) + + ! For CRM, make cloud equal to input observations: + if (scm_crm_mode .and. have_cld) then + do k = 1, pver + cld(:ncol,k)= cldobs(k) + end do + end if + + + ! Find tropopause height if needed for diagnostic output + if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then + call tropopause_find(state, troplev, tropP=p_trop, & + primary=TROP_ALG_HYBSTOB, & + backup=TROP_ALG_CLIMATE) + end if + + ! Get time of next radiation calculation - albedos will need to be + ! calculated by each surface model at this time + nextsw_cday = radiation_nextsw_cday() + + + ! if Nday = 0, then we should not do shortwave, + ! *but* at then end of subroutine, heating rates will still be calculated, + ! and would get whatever is in pbuf for qrl / qrs. + ! To avoid non-daylit columns + ! from having shortwave heating, we should reset here: + if (nday == 0) then + qrs(1:ncol,1:pver) = 0 + rd%qrsc(1:ncol,1:pver) = 0 ! this is what gets turned into QRSC in output (probably not needed here.) + dosw = .false. + end if + + ! On first time step, do we need to initialize the heating rates in pbuf? + ! what about on a restart? + if (get_nstep() == 0) then + qrs = 0._r8 + qrl = 0._r8 + end if + + + if (dosw .or. dolw) then + + allocate( & + t_sfc(ncol), & + emis_sfc(nlwbands,ncol), & + 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) & + ) + + + call rrtmgp_set_state( & ! Prepares state variables, daylit columns, albedos for RRTMGP + state, & ! input (%t, %pmid, %pint) + cam_in, & ! input (%lwup, %aldir, %asdir, %aldif, %asdif) + ncol, & ! input + nlay, & ! input + nlwbands, & ! input + nswbands, & ! input + ngpt_sw, & ! input + nday, & ! input + idxday, & ! input, [would prefer to truncate as 1:ncol] + coszrs, & ! input + kdist_sw, & ! input (from init) ! removed: eccf, & ! input + band2gpt_sw, & ! input (from init), gpoints by band + t_sfc, & ! output + emis_sfc, & ! output + t_rad, & ! output + pmid_rad, & ! output + pint_rad, & ! output + t_day, & ! output + pmid_day, & ! output + pint_day, & ! output + coszrs_day, & ! output + alb_dir, & ! output + alb_dif, & ! output + tsi & ! output, total solar irradiance (not scaled) + ) + nlevrad = size(t_rad,2) + + !!--> Set TSI used in radiation to the value in the solar forcing file. + !!--> This replaces get_variability() and does same thing. + !!--> The Earth-Sun distance (eccf) provides another scaling, applied later. + errmsg = kdist_sw%set_tsi(tsi) ! scales the TSI but does not change spectral distribution + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: kdist_sw%set_tsi: '//trim(errmsg)) + end if + + ! check bounds for temperature -- These are specified in the coefficients file, + ! and RRTMGP will not operate if outside the specified range. + call clipper(t_day, kdist_lw%get_temp_min(), kdist_lw%get_temp_max()) + call clipper(t_rad, kdist_lw%get_temp_min(), kdist_lw%get_temp_max()) + + ! Modify cloud fraction to account for radiatively active snow and/or graupel + call modified_cloud_fraction(cld, cldfsnow, cldfgrau, cldfsnow_idx, cldfgrau_idx, cldfprime) + + + if (dosw) then + ! + ! "--- SET OPTICAL PROPERTIES & DO SHORTWAVE CALCULATION ---" + ! + if (oldcldoptics) then + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) + else + select case (icecldoptics) + case ('ebertcurry') + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.true.) + case ('mitchell') + call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) + case default + call endrun('iccldoptics must be one either ebertcurry or mitchell') + end select + + select case (liqcldoptics) + case ('slingo') + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) + case ('gammadist') + call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) + case default + call endrun('liqcldoptics must be either slingo or gammadist') + end select + end if + + cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) + cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) + cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) + cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) + + if (cldfsnow_idx > 0) then + ! add in snow + call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, snow_tau_w_f) + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0.) then + c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & + + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & + + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & + + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & + + cld(i,k)*cld_tau_w_f(:,i,k) )/cldfprime(i,k) + else + c_cld_tau(:,i,k) = 0._r8 + c_cld_tau_w(:,i,k) = 0._r8 + c_cld_tau_w_g(:,i,k) = 0._r8 + c_cld_tau_w_f(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) + c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) + c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) + c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) + end if + + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + ! add in graupel + call get_grau_optics_sw(state, pbuf, grau_tau, grau_tau_w, grau_tau_w_g, grau_tau_w_f) + do i = 1, ncol + do k = 1, pver + + if (cldfprime(i,k) > 0._r8) then + + c_cld_tau(:,i,k) = ( cldfgrau(i,k)*grau_tau(:,i,k) & + + cld(i,k)*c_cld_tau(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w(:,i,k) = ( cldfgrau(i,k)*grau_tau_w(:,i,k) & + + cld(i,k)*c_cld_tau_w(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_g(:,i,k) = ( cldfgrau(i,k)*grau_tau_w_g(:,i,k) & + + cld(i,k)*c_cld_tau_w_g(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_f(:,i,k) = ( cldfgrau(i,k)*grau_tau_w_f(:,i,k) & + + cld(i,k)*c_cld_tau_w_f(:,i,k) )/cldfprime(i,k) + else + c_cld_tau(:,i,k) = 0._r8 + c_cld_tau_w(:,i,k) = 0._r8 + c_cld_tau_w_g(:,i,k) = 0._r8 + c_cld_tau_w_f(:,i,k) = 0._r8 + end if + end do + end do + end if + + ! At this point we have cloud optical properties including snow and graupel, + ! but they need to be re-ordered from the old RRTMG spectral bands to RRTMGP's + ! + ! Mapping from old RRTMG sw bands to new band ordering in RRTMGP + ! 1. This should be automated to provide generalization to arbitrary spectral grid. + ! 2. This is used for setting cloud and aerosol optical properties, so probably should be put into a different module. + c_cld_tau(:,1:ncol,1:pver) = c_cld_tau (rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) + c_cld_tau_w(:,1:ncol,1:pver) = c_cld_tau_w (rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) + c_cld_tau_w_g(:,1:ncol,1:pver) = c_cld_tau_w_g(rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) + c_cld_tau_w_f(:,1:ncol,1:pver) = c_cld_tau_w_f(rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) + + ! cloud_sw : cloud optical properties. + call initialize_rrtmgp_cloud_optics_sw(nday, nlay, kdist_sw, cloud_sw) + + call rrtmgp_set_cloud_sw( & ! the result cloud_sw is gpoints ("quadrature" points) + nswbands, & ! input + nday, & ! input + nlay, & ! input + idxday(1:ncol), & ! input, [require to truncate to 1 to ncol b/c the array is size pcol] + pmid_day(:,nlay:1:-1), & ! input + cldfprime, & ! input + c_cld_tau, & ! input + c_cld_tau_w, & ! input + c_cld_tau_w_g, & ! input + c_cld_tau_w_f, & ! input + kdist_sw, & ! input + cloud_sw & ! inout, outputs %g, %ssa, %tau + ) + + ! allocate object for aerosol optics + errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber(), & + name='shortwave aerosol optics') + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: aer_sw%alloc_2str: '//trim(errmsg)) + end if + + ! + ! SHORTWAVE DIAGNOSTICS & OUTPUT + ! + ! cloud optical depth fields for the visible band + ! This uses idx_sw_diag to get a specific band; + ! is hard-coded in radconstants and is correct for RRTMGP ordering. + rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) ! should be equal to cloud_sw%tau except ordering + rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) + rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) + if (cldfsnow_idx > 0) then + rd%snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) + endif + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + rd%grau_icld_vistau(:ncol,:) = grau_tau(idx_sw_diag,:ncol,:) + endif + + ! multiply by total cloud fraction to get gridbox value + rd%tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) + + ! add fillvalue for night columns + do i = 1, Nnite + rd%tot_cld_vistau(IdxNite(i),:) = fillvalue + rd%tot_icld_vistau(IdxNite(i),:) = fillvalue + rd%liq_icld_vistau(IdxNite(i),:) = fillvalue + rd%ice_icld_vistau(IdxNite(i),:) = fillvalue + if (cldfsnow_idx > 0) then + rd%snow_icld_vistau(IdxNite(i),:) = fillvalue + end if + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + rd%grau_icld_vistau(IdxNite(i),:) = fillvalue + end if + end do + + if (write_output) then + call radiation_output_cld(lchnk, ncol, rd) + end if + ! + ! SHORTWAVE CALCULATION(S) + ! + ! Get the active climate/diagnostic shortwave calculations + call rad_cnst_get_call_list(active_calls) + + ! The climate (icall==0) calculation must occur last. + do icall = N_DIAG, 0, -1 + if (active_calls(icall)) then + call set_available_gases(active_gases, gas_concs_sw) ! set gas concentrations + + call rrtmgp_set_gases_sw( & ! Put gas volume mixing ratio into gas_concs_sw + icall, & ! input + state, & ! input ; note: state/pbuf are top-to-bottom + pbuf, & ! input + nlay, & ! input + nday, & ! input + idxday, & ! input [this is full array, but could be 1:nday] + gas_concs_sw & ! inout ; will be bottom-to-top !! concentrations will be size ncol, but only 1:nday should be used + ) + + call aer_rad_props_sw( & ! Get aerosol shortwave optical properties + icall, & ! input + state, & ! input + pbuf, & ! input pointer + nnite, & ! input + idxnite, & ! input + aer_tau, & ! output + aer_tau_w, & ! output + aer_tau_w_g, & ! output + aer_tau_w_f & ! output + ) + ! NOTE: CAM fields are products tau, tau*ssa, tau*ssa*asy, tau*ssa*asy*fsf + ! but RRTMGP is expecting just the values per band. + ! rrtmgp_set_aer_sw does the division and puts values into aer_sw: + ! aer_sw%g = aer_tau_w_g / aer_taw_w + ! aer_sw%ssa = aer_tau_w / aer_tau + ! aer_sw%tau = aer_tau + ! ** As with cloud above, we need to re-order to account for band differences: + + aer_tau(:, :, :) = aer_tau( :, :, rrtmg_to_rrtmgp_swbands) + aer_tau_w(:, :, :) = aer_tau_w( :, :, rrtmg_to_rrtmgp_swbands) + aer_tau_w_g(:, :, :) = aer_tau_w_g(:, :, rrtmg_to_rrtmgp_swbands) + aer_tau_w_f(:, :, :) = aer_tau_w_f(:, :, rrtmg_to_rrtmgp_swbands) + + ! Convert from the products to individual properties, + ! and only provide them on the daylit points. + call rrtmgp_set_aer_sw( & + nswbands, & + nday, & + idxday(1:nday), & ! required to truncate to 1:nday + aer_tau, & + aer_tau_w, & + aer_tau_w_g, & + aer_tau_w_f, & + aer_sw) + + ! Compute SW fluxes + + ! check that optical properties are in bounds: + call clipper(cloud_sw%tau, 0._r8, huge(cloud_sw%tau)) + call clipper(cloud_sw%ssa, 0._r8, 1._r8) + call clipper(cloud_sw%g, -1._r8, 1._r8) + + ! CHECK BOUNDS OF ARRAYS: + ! errmsg = cloud_sw%validate() ! rte provides validate method for tau, ssa, and g all at once. + ! if (len_trim(errmsg) > 0) then + ! call endrun(sub//': ERROR code returned by check_bounds cloud_sw: '//trim(errmsg)) + ! end if + ! errmsg = aer_sw%validate() ! rte provides validate method for tau, ssa, and g all at once. + ! if (len_trim(errmsg) > 0) then + ! call endrun(sub//': ERROR code returned by check_bounds aer_sw: '//trim(errmsg)) + ! end if + ! call check_bounds(alb_dir, 1.0_r8, 0.0_r8, errmsg) + ! if (len_trim(errmsg) > 0) then + ! call endrun(sub//': ERROR code returned by check_bounds alb_dir: '//trim(errmsg)) + ! end if + ! call check_bounds(alb_dif, 1.0_r8, 0.0_r8, errmsg) + ! if (len_trim(errmsg) > 0) then + ! call endrun(sub//': ERROR code returned by check_bounds alb_dif: '//trim(errmsg)) + ! end if + ! call check_bounds(coszrs_day, 1.0_r8, 0.0_r8, errmsg) + ! if (len_trim(errmsg) > 0) then + ! call endrun(sub//': ERROR code returned by check_bounds coszrs_day: '//trim(errmsg)) + ! end if + ! call check_bounds(pint_day, 120000.0_r8, 1.0_r8, errmsg) ! Pa -- give pretty big bounds + ! if (len_trim(errmsg) > 0) then + ! call endrun(sub//': ERROR code returned by check_bounds pint_day: '//trim(errmsg)) + ! end if + ! call check_bounds(t_day, 350.0_r8, 150.0_r8, errmsg) ! K -- give pretty big bounds + ! if (len_trim(errmsg) > 0) then + ! call endrun(sub//': ERROR code returned by check_bounds t_day: '//trim(errmsg)) + ! end if + ! call check_bounds(pmid_day, 120000.0_r8, 1.0_r8, errmsg) ! Pa -- give pretty big bounds + ! if (len_trim(errmsg) > 0) then + ! call endrun(sub//': ERROR code returned by check_bounds pint_day: '//trim(errmsg)) + ! end if + + + ! Still to validate: + ! - kdist_sw + ! - gas_concs_sw + ! call check_bounds(nday, nlay, gas_concs_sw, errmsg) + ! if (len_trim(errmsg) > 0) then + ! call endrun(sub//': ERROR code returned by check_bounds gas_concs_sw: '//trim(errmsg)) + ! end if + ! call check_bounds(kdist_sw, errmsg) + call shr_mem_getusage(mem_hw_beg, mem_beg) + ! inputs are the daylit columns --> output fluxes therefore also on daylit columns. + errmsg = rte_sw( kdist_sw, & ! input (from init) + gas_concs_sw, & ! input, (from rrtmgp_set_gases_sw) + pmid_day, & ! input, (from rrtmgp_set_state) + t_day, & ! input, (from rrtmgp_set_state) + pint_day, & ! input, (from rrtmgp_set_state) + coszrs_day, & ! input, (from rrtmgp_set_state) + alb_dir, & ! input, (from rrtmgp_set_state) + alb_dif, & ! input, (from rrtmgp_set_state) + cloud_sw, & ! input, (from rrtmgp_set_cloud_sw) + fsw, & ! inout + fswc, & ! inout + aer_props=aer_sw, & ! optional input (from rrtmgp_set_aer_sw) + tsi_scaling=eccf & !< optional input, scaling for irradiance + ) + + call shr_mem_getusage(mem_hw_end, mem_end) + temp = mem_hw_end - mem_hw_beg + if (masterproc) then + write(iulog, *) 'rte_sw: Increase in memory highwater = ', & + temp, ' (MB)' + end if + temp = mem_end - mem_beg + if (masterproc) then + write(iulog, *) 'rte_sw: Increase in memory usage = ', & + temp, ' (MB)' + end if + + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR code returned by rte_sw: '//trim(errmsg)) + end if + ! + ! -- shortwave output -- + ! + + ! Transform RRTMGP outputs to CAM outputs + ! - including fsw (W/m2) -> qrs (J/(kgK)) + call set_sw_diags() + + if (write_output) then + call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) ! QRS = qrs/cpair; whatever qrs is in pbuf + end if + + end if ! (active_calls(icall)) + end do ! loop over diagnostic calcs (icall) + + else + if (conserve_energy) then + qrs(1:ncol,1:pver) = qrs(1:ncol,1:pver) / state%pdel(1:ncol,1:pver) + end if + end if ! if (dosw) + + ! Output aerosol mmr + ! This happens between SW and LW (Why?) + call rad_cnst_out(0, state, pbuf) + + ! + ! -- LONGWAVE -- + ! + if (dolw) then + if (oldcldoptics) then + call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) + else + select case (icecldoptics) + case ('ebertcurry') + call ec_ice_get_rad_props_lw(state, pbuf, ice_lw_abs, oldicewp=.true.) + case ('mitchell') + call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) + case default + call endrun('ERROR: iccldoptics must be one either ebertcurry or mitchell') + end select + + select case (liqcldoptics) + case ('slingo') + call slingo_liq_get_rad_props_lw(state, pbuf, liq_lw_abs, oldliqwp=.true.) + case ('gammadist') + call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) + case default + call endrun('ERROR: liqcldoptics must be either slingo or gammadist') + end select + + cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) + end if + + cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) + if (cldfsnow_idx > 0) then + ! add in snow + call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0._r8) then + c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & + + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) + else + c_cld_lw_abs(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) + end if + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + ! add in graupel + call grau_cloud_get_rad_props_lw(state, pbuf, grau_lw_abs) + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0._r8) then + c_cld_lw_abs(:,i,k) = ( cldfgrau(i,k)*grau_lw_abs(:,i,k) & + + cld(i,k)*c_cld_lw_abs(:,i,k) )/cldfprime(i,k) + else + c_cld_lw_abs(:,i,k) = 0._r8 + end if + end do + end do + end if + + ! cloud_lw : cloud optical properties. + call initialize_rrtmgp_cloud_optics_lw(ncol, nlay, kdist_lw, cloud_lw) + + call rrtmgp_set_cloud_lw( & ! Sets the LW optical depth (tau) that is passed to RRTMGP + state, & ! input (%ncol, %pmid [top-to-bottom]) + nlwbands, & ! input + cldfprime, & ! input Ordered top-to-bottom + c_cld_lw_abs, & ! input Ordered top-to-bottom + kdist_lw, & ! input (%get_ngpt, and whole object passed to mcica) + cloud_lw & ! inout (%tau is set, and returned bottom-to-top) + ) + + ! initialize/allocate object for aerosol optics (note, don't just give it nlwbands b/c wrong type) + errmsg = aer_lw%alloc_1scl(ncol, & + nlay, & + kdist_lw%get_band_lims_wavenumber(), & + name='longwave aerosol optics') + + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: aer_lw%init_1scalar: '//trim(errmsg)) + end if + + call rad_cnst_get_call_list(active_calls) ! get list of diagnostic calls + + ! The climate (icall==0) calculation must occur last. + do icall = N_DIAG, 0, -1 + + if (active_calls(icall)) then + ! initialize the gas concentrations + call set_available_gases(active_gases, gas_concs_lw) +! errmsg = gas_concs_lw%init(active_gases) +! if (len_trim(errmsg) > 0) then +! call endrun(sub//': ERROR code returned by gas_concs_lw%init: '//trim(errmsg)) +! end if + call rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs_lw) + + call aer_rad_props_lw( & ! get absorption optical depth + icall, & ! input + state, & ! input + pbuf, & ! input + aer_lw_abs & ! outut + ) + call rrtmgp_set_aer_lw( & ! put absorption optical depth into aer_lw + ncol, & ! input + nlwbands, & ! input + aer_lw_abs, & ! input + aer_lw & ! output, %tau, ordered bottom-to-top + ) + + ! check that optical properties are in bounds: + call clipper(cloud_lw%tau, 0._r8, huge(cloud_lw%tau)) + call clipper(aer_lw%tau, 0._r8, huge(aer_lw%tau)) + + ! Compute LW fluxes + errmsg = rte_lw(kdist_lw, & ! input + gas_concs_lw, & ! input, (rrtmgp_set_gases_lw) + pmid_rad, & ! input, (rrtmgp_set_state) + t_rad, & ! input, (rrtmgp_set_state) + pint_rad, & ! input, (rrtmgp_set_state) + t_sfc, & ! input (rrtmgp_set_state) + emis_sfc, & ! input (rrtmgp_set_state) + cloud_lw, & ! input, (rrtmgp_set_cloud_lw) + flw, & ! output + flwc, & ! output + aer_props=aer_lw & ! optional input, (rrtmgp_set_aer_lw) + ) ! note inc_flux is an optional input, but as defined in set_rrtmgp_state, it is only for shortwave + if (len_trim(errmsg) > 0) then + ! + ! DEBUG -- if we die here, find out why + ! + write(iulog,*) '** [radiation_tend] DIAGNOSE LW CRASH **' + do i = 1,ncol + write(iulog,*) 'ncol = ',ncol,' t_sfc = ',t_sfc(i),' AT LOCATION lat = ', clat(i), ' lon = ', clon(i) + end do + call endrun(sub//': ERROR code returned by rte_lw: '//trim(errmsg)) + end if + ! + ! -- longwave output -- + ! + call set_lw_diags() ! Reverse direction of LW fluxes back to TOP-to-BOTTOM + ! And derive LW dry static energy tendency (QRL, rd%QRLC (J/kg/s)) + if (write_output) then + ! QRL retrieved from pbuf and divided by cpair [(J/(kg s)) / (J/(K kg)) = K/s] + call radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out) + end if + + end if + end do + + else + if (conserve_energy) then + qrl(1:ncol,1:pver) = qrl(1:ncol,1:pver) / state%pdel(1:ncol,1:pver) + end if + end if ! if (dolw) + + ! replaces old "rrtmg_state_destroy" -- deallocates outputs from rrtmgp_set_state() + ! note rd%solin is not being deallocated here, but rd is deallocated after the output stage. + deallocate( & + t_sfc, emis_sfc, t_rad, pmid_rad, pint_rad, & + t_day, pmid_day, pint_day, coszrs_day, alb_dir, & + alb_dif) + + + !!! *** BEGIN COSP *** + if (docosp) then + ! initialize and calculate emis + emis(:,:) = 0._r8 + emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(lw_cloudsim_band,:ncol,:)) + call outfld('EMIS', emis, pcols, lchnk) + + ! compute grid-box mean SW and LW snow optical depth for use by COSP + gb_snow_tau(:,:) = 0._r8 + gb_snow_lw(:,:) = 0._r8 + if (cldfsnow_idx > 0) then + do i = 1, ncol + do k = 1, pver + if (cldfsnow(i,k) > 0._r8) then + + ! Add graupel to snow tau for cosp + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + gb_snow_tau(i,k) = snow_tau(sw_cloudsim_band,i,k)*cldfsnow(i,k) + & + grau_tau(sw_cloudsim_band,i,k)*cldfgrau(i,k) + gb_snow_lw(i,k) = snow_lw_abs(lw_cloudsim_band,i,k)*cldfsnow(i,k) + & + grau_lw_abs(lw_cloudsim_band,i,k)*cldfgrau(i,k) + else + gb_snow_tau(i,k) = snow_tau(sw_cloudsim_band,i,k)*cldfsnow(i,k) + gb_snow_lw(i,k) = snow_lw_abs(lw_cloudsim_band,i,k)*cldfsnow(i,k) + end if + end if + end do + end do + end if + + ! advance counter for this timestep (chunk dimension required for thread safety) + cosp_cnt(lchnk) = cosp_cnt(lchnk) + 1 + + ! if counter is the same as cosp_nradsteps, run cosp and reset counter + if (cosp_nradsteps .eq. cosp_cnt(lchnk)) then + + ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave + ! optical depths are passed. + call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & + cld_swtau_in=cld_tau(sw_cloudsim_band,:,:),& + snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) + cosp_cnt(lchnk) = 0 + end if + end if + !!! *** END COSP *** + + else ! if (dosw .or. dolw) --> no radiation being done. + ! convert radiative heating rates from Q*dp to Q for energy conservation + ! qrs and qrl are whatever are in pbuf + ! since those might have been multiplied by pdel, we actually need to divide by pdel + ! to get back to what we want, which is a DSE tendency. + ! ** if you change qrs and qrl from J/kg/s here, then it won't be a DSE tendency, + ! yet it is expected to be in radheat_tend to get ptend%s + ! Does not matter if qrs and qrl are zero on these time steps + + ! this completes the conserve_energy logic, since neither sw nor lw ran + if (conserve_energy) then + qrs(1:ncol,1:pver) = qrs(1:ncol,1:pver) / state%pdel(1:ncol,1:pver) + qrl(1:ncol,1:pver) = qrl(1:ncol,1:pver) / state%pdel(1:ncol,1:pver) + end if + + end if ! if (dosw .or. dolw) then + + ! write(iulog,*) 'Radiation_Tend finished calculation [timestep ',get_nstep(), ', chunk: ',lchnk,'] -- qrs max: ',maxval(qrs),' min: ',minval(qrs),' -- qrl max: ',maxval(qrl), ' min: ',minval(qrl) + + + ! ------------------------------------------------------------------------ + ! + ! After any radiative transfer is done: output & convert fluxes to heating + ! + + call rad_data_write(pbuf, state, cam_in, coszrs) ! output rad inputs and resulting heating rates + + ! NET RADIATIVE HEATING TENDENCY + ! INPUT: state, qrl, qrs, fsns, fsnt, flns, flnt, asdir + ! OUTPUT: + ! ptend%s = (qrs + qrl) + ! net_flx = fsnt - fsns - flnt + flns + ! pbuf is an argument, but *is not used* (qrl/qrs are pointers into it) + call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & + fsnt, flns, flnt, cam_in%asdir, net_flx) + + if (write_output) then + ! Compute heating rate for dtheta/dt + do k = 1, pver + do i = 1, ncol + ftem(i,k) = (qrs(i,k) + qrl(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa + end do + end do + call outfld('HR', ftem, pcols, lchnk) + end if + + ! convert radiative heating rates to Q*dp for energy conservation + ! QRS & QRL should be in J/(kg s) (dry static energy tendency); not sure where this goes after radiation. + if (conserve_energy) then + qrs(1:ncol,1:pver) = qrs(1:ncol,1:pver) * state%pdel(1:ncol,1:pver) + qrl(1:ncol,1:pver) = qrl(1:ncol,1:pver) * state%pdel(1:ncol,1:pver) + end if + + if (.not. present(rd_out)) then + deallocate(rd) + end if + call free_optics_sw(cloud_sw) + call free_optics_sw(aer_sw) + call free_fluxes(fsw) + call free_fluxes(fswc) + + call free_optics_lw(cloud_lw) + call free_optics_lw(aer_lw) + call free_fluxes(flw) + call free_fluxes(flwc) + + ! write(iulog,*) 'Radiation_Tend END [timestep ',get_nstep(), ', chunk: ',lchnk,']' + +!------------------------------------------------------------------------------- +contains +!------------------------------------------------------------------------------- + + subroutine set_sw_diags() + + ! Transform RRTMGP output for CAM + ! Uses the fluxes that come out of RRTMGP. + + ! Expects fluxes on day columns, and expands to full columns. + + integer :: i + real(r8), dimension(size(fsw%bnd_flux_dn,1), & + size(fsw%bnd_flux_dn,2), & + size(fsw%bnd_flux_dn,3)) :: flux_dn_diffuse + !------------------------------------------------------------------------- + fns = 0._r8 ! net sw flux + fcns = 0._r8 ! net sw clearsky flux + fsds = 0._r8 ! downward sw flux at surface + rd%fsdsc = 0._r8 ! downward sw clearsky flux at surface + rd%fsutoa = 0._r8 ! upward sw flux at TOA + rd%fsntoa = 0._r8 ! net sw at TOA + rd%fsntoac = 0._r8 ! net sw clearsky flux at TOA + rd%solin = 0._r8 ! solar irradiance at TOA + + ! fns, fcns, rd are on CAM grid (do not have "extra layer" when it is present.) + ! fill in the daylit columns: + do i = 1, nday + fns(idxday(i),ktopcami:) = fsw%flux_net(i, ktopradi:) + fcns(idxday(i),ktopcami:) = fswc%flux_net(i,ktopradi:) + rd%flux_sw_up(idxday(i),ktopcami:) = & + fsw%flux_up(i,ktopradi:) + rd%flux_sw_dn(idxday(i),ktopcami:) = & + fsw%flux_dn(i,ktopradi:) + rd%flux_sw_clr_up(idxday(i),ktopcami:) = & + fswc%flux_up(i,ktopradi:) + rd%flux_sw_clr_dn(idxday(i),ktopcami:) = & + fswc%flux_dn(i,ktopradi:) + fsds(idxday(i)) = fsw%flux_dn(i, nlay+1) + rd%fsdsc(idxday(i)) = fswc%flux_dn(i, nlay+1) + rd%fsutoa(idxday(i)) = fsw%flux_up(i, ktopradi) + rd%fsntoa(idxday(i)) = fsw%flux_net(i, ktopradi) ! net sw flux at TOA (*NOT* the same as fsnt) + rd%fsntoac(idxday(i)) = fswc%flux_net(i, ktopradi) ! net sw clearsky flux at TOA (*NOT* the same as fsntc) + rd%solin(idxday(i)) = fswc%flux_dn(i, ktopradi) + end do + + call heating_rate('SW', ncol, fns, qrs) + call heating_rate('SW', ncol, fcns, rd%qrsc) + + fsns(:ncol) = fns(:ncol,pverp) ! net sw flux at surface + fsnt(:ncol) = fns(:ncol,1) ! net sw flux at top-of-model (w/o extra layer) + rd%flux_sw_net_top(:ncol) = fns(:ncol, 1) + rd%fsnsc(:ncol) = fcns(:ncol,pverp) ! net sw clearsky flux at surface + rd%fsntc(:ncol) = fcns(:ncol,1) ! net sw clearsky flux at top + + cam_out%netsw(:ncol) = fsns(:ncol) + + ! Output fluxes at 200 mb + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fns, rd%fsn200) + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) + if (hist_fld_active('FSNR')) then + do i = 1,ncol + call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fns(i,:), rd%fsnr(i)) + end do + end if + + if (spectralflux) then + su = 0._r8 + sd = 0._r8 + do i = 1, nday + su(idxday(i),ktopcami:,:) = fsw%bnd_flux_up(i,ktopradi:,:) + sd(idxday(i),ktopcami:,:) = fsw%bnd_flux_dn(i,ktopradi:,:) + end do + end if + + ! Export surface fluxes + ! sols(pcols) Direct solar rad on surface (< 0.7) + ! soll(pcols) Direct solar rad on surface (>= 0.7) + ! RRTMG: Near-IR bands (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns + ! RRTMGP: Near-IR bands (1-10), 820-16000 cm-1, 0.625-12.195 microns + ! Put half of band 10 in each of the UV/visible and near-IR values, + ! since this band straddles 0.7 microns: + ! UV/visible bands 10-13, 16000-50000 cm-1, 0.200-0.625 micron + + ! reset fluxes + cam_out%sols = 0.0_r8 + cam_out%soll = 0.0_r8 + cam_out%solsd = 0.0_r8 + cam_out%solld = 0.0_r8 + + ! Calculate diffuse flux from total and direct + flux_dn_diffuse = fsw%bnd_flux_dn - fsw%bnd_flux_dn_dir + + do i = 1, nday + ! These use hard-coded indexes assuming default RRTMGP sw bands + ! Should be generalized to use specified frequencies. + cam_out%soll(idxday(i)) = sum(fsw%bnd_flux_dn_dir(i,nlay+1,1:9)) & + + 0.5_r8 * fsw%bnd_flux_dn_dir(i,nlay+1,10) + + cam_out%sols(idxday(i)) = 0.5_r8 * fsw%bnd_flux_dn_dir(i,nlay+1,10) & + + sum(fsw%bnd_flux_dn_dir(i,nlay+1,11:14)) + + cam_out%solld(idxday(i)) = sum(flux_dn_diffuse(i,nlay+1,1:9)) & + + 0.5_r8 * flux_dn_diffuse(i,nlay+1,10) + + cam_out%solsd(idxday(i)) = 0.5_r8 * flux_dn_diffuse(i, nlay+1, 10) & + + sum(flux_dn_diffuse(i,nlay+1,11:14)) + + end do + + end subroutine set_sw_diags + + !------------------------------------------------------------------------------- + + subroutine set_lw_diags() + + ! Transform RRTMGP output for CAM + ! Assumes RRTMGP levels are bottom to top (though it does not care need to be consistent). + ! CAM levels are top to bottom. + !---------------------------------------------------------------------------- + + fnl = 0._r8 + fcnl = 0._r8 + + ! RTE-RRTMGP convention for net is (down - up) **CAM assumes (up - down) !! + fnl(:ncol,ktopcami:) = -1._r8 * flw%flux_net( :, ktopradi:) + fcnl(:ncol,ktopcami:) = -1._r8 * flwc%flux_net( :, ktopradi:) + rd%flux_lw_up(:ncol,ktopcami:) = flw%flux_up( :, ktopradi:) + rd%flux_lw_clr_up(:ncol,ktopcami:) = flwc%flux_up(:, ktopradi:) + rd%flux_lw_dn(:ncol,ktopcami:) = flw%flux_dn( :, ktopradi:) + rd%flux_lw_clr_dn(:ncol,ktopcami:) = flwc%flux_dn(:, ktopradi:) + + call heating_rate('LW', ncol, fnl, qrl) + call heating_rate('LW', ncol, fcnl, rd%qrlc) + + flns(:ncol) = fnl(:ncol, pverp) + flnt(:ncol) = fnl(:ncol, 1) + + rd%flnsc(:ncol) = fcnl(:ncol, pverp) + rd%flntc(:ncol) = fcnl(:ncol, 1) ! net lw flux at top-of-model + + cam_out%flwds(:ncol) = flw%flux_dn(:, nlay+1) + rd%fldsc(:ncol) = flwc%flux_dn(:, nlay+1) + + rd%flut(:ncol) = flw%flux_up(:, ktopradi) + rd%flutc(:ncol) = flwc%flux_up(:, ktopradi) + + ! Output fluxes at 200 mb + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) + if (hist_fld_active('FLNR')) then + do i = 1,ncol + call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fnl(i,:), rd%flnr(i)) + end do + end if + + if (spectralflux) then + lu = 0._r8 + ld = 0._r8 + lu(:ncol, ktopcami:, :) = flw%bnd_flux_up(:, ktopradi:, :) + ld(:ncol, ktopcami:, :) = flw%bnd_flux_dn(:, ktopradi:, :) + end if + + end subroutine set_lw_diags + + !------------------------------------------------------------------------------- + + subroutine heating_rate(type, ncol, flux_net, hrate) + + ! Compute heating rate as a dry static energy tendency + + ! arguments + character(2), intent(in) :: type ! either LW or SW + integer, intent(in) :: ncol + real(r8), intent(in) :: flux_net(pcols,pverp) ! W/m^2 + real(r8), intent(out) :: hrate(pcols,pver) ! J/kg/s + + ! local vars + integer :: k + + select case (type) + case ('LW') + + do k = 1, 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) + end do + + case ('SW') + + do k = 1, pver + ! top - bottom + hrate(:ncol,k) = (flux_net(:ncol,k) - flux_net(:ncol,k+1)) * & + gravit / state%pdel(:ncol,k) + end do + + end select + + end subroutine heating_rate + + !---------------------------------------------------------------------------- + ! -- end contains statement of radiation_tend -- + !---------------------------------------------------------------------------- +end subroutine radiation_tend + +!=============================================================================== + + +subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) + + ! Dump shortwave radiation information to history buffer. + + integer , intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: icall + type(rad_out_t), intent(in) :: rd + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(in) :: cam_out + + ! local variables + real(r8), pointer :: qrs(:,:) + real(r8), pointer :: fsnt(:) + real(r8), pointer :: fsns(:) + real(r8), pointer :: fsds(:) + real(r8), pointer :: su(:,:),sd(:,:),lu(:,:),ld(:,:) + + real(r8) :: ftem(pcols) + !---------------------------------------------------------------------------- + + call pbuf_get_field(pbuf, qrs_idx, qrs) + call pbuf_get_field(pbuf, fsnt_idx, fsnt) + call pbuf_get_field(pbuf, fsns_idx, fsns) + call pbuf_get_field(pbuf, fsds_idx, fsds) + + call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) + + call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) ! not sure why ncol instead of pcols, but matches RRTMG version + call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) + + call outfld('FSNT'//diag(icall), rd%flux_sw_net_top, pcols, lchnk) + call outfld('FSNTC'//diag(icall), rd%fsntc, pcols, lchnk) + call outfld('FSNTOA'//diag(icall), rd%fsntoa, pcols, lchnk) + call outfld('FSNTOAC'//diag(icall), rd%fsntoac, pcols, lchnk) + + ftem(:ncol) = rd%fsntoa(:ncol) - rd%fsntoac(:ncol) + call outfld('SWCF'//diag(icall), ftem, pcols, lchnk) + + call outfld('FSUTOA'//diag(icall), rd%fsutoa, pcols, lchnk) + + call outfld('FSNIRTOA'//diag(icall), rd%fsnirt, pcols, lchnk) + call outfld('FSNRTOAC'//diag(icall), rd%fsnrtc, pcols, lchnk) + call outfld('FSNRTOAS'//diag(icall), rd%fsnirtsq, pcols, lchnk) + + call outfld('FSN200'//diag(icall), rd%fsn200, pcols, lchnk) + call outfld('FSN200C'//diag(icall), rd%fsn200c, pcols, lchnk) + + call outfld('FSNR'//diag(icall), rd%fsnr, pcols, lchnk) + + call outfld('SOLS'//diag(icall), cam_out%sols, pcols, lchnk) + call outfld('SOLL'//diag(icall), cam_out%soll, pcols, lchnk) + call outfld('SOLSD'//diag(icall), cam_out%solsd, pcols, lchnk) + call outfld('SOLLD'//diag(icall), cam_out%solld, pcols, lchnk) + + call outfld('FSNS'//diag(icall), fsns, pcols, lchnk) + call outfld('FSNSC'//diag(icall), rd%fsnsc, pcols, lchnk) + + call outfld('FSDS'//diag(icall), fsds, pcols, lchnk) + call outfld('FSDSC'//diag(icall), rd%fsdsc, pcols, lchnk) + + call outfld('FUS'//diag(icall), rd%flux_sw_up, pcols, lchnk) + call outfld('FUSC'//diag(icall), rd%flux_sw_clr_up, pcols, lchnk) + call outfld('FDS'//diag(icall), rd%flux_sw_dn, pcols, lchnk) + call outfld('FDSC'//diag(icall), rd%flux_sw_clr_dn, pcols, lchnk) + +end subroutine radiation_output_sw + + +!=============================================================================== + +subroutine radiation_output_cld(lchnk, ncol, rd) + + ! Dump shortwave cloud optics information to history buffer. + + integer , intent(in) :: lchnk + integer, intent(in) :: ncol + type(rad_out_t), intent(in) :: rd + !---------------------------------------------------------------------------- + + call outfld('TOT_CLD_VISTAU', rd%tot_cld_vistau, pcols, lchnk) + call outfld('TOT_ICLD_VISTAU', rd%tot_icld_vistau, pcols, lchnk) + call outfld('LIQ_ICLD_VISTAU', rd%liq_icld_vistau, pcols, lchnk) + call outfld('ICE_ICLD_VISTAU', rd%ice_icld_vistau, pcols, lchnk) + if (cldfsnow_idx > 0) then + call outfld('SNOW_ICLD_VISTAU', rd%snow_icld_vistau, pcols, lchnk) + endif + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + call outfld('GRAU_ICLD_VISTAU', rd%grau_icld_vistau , pcols, lchnk) + endif + +end subroutine radiation_output_cld + +!=============================================================================== + +subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out) + + ! Dump longwave radiation information to history buffer + + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: icall ! icall=0 for climate diagnostics + type(rad_out_t), intent(in) :: rd + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(in) :: cam_out + + ! local variables + real(r8), pointer :: qrl(:,:) + real(r8), pointer :: flnt(:) + real(r8), pointer :: flns(:) + + real(r8) :: ftem(pcols) + !---------------------------------------------------------------------------- + + call pbuf_get_field(pbuf, qrl_idx, qrl) + call pbuf_get_field(pbuf, flnt_idx, flnt) + call pbuf_get_field(pbuf, flns_idx, flns) + + call outfld('QRL'//diag(icall), qrl(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRLC'//diag(icall), rd%qrlc(:ncol,:)/cpair, ncol, lchnk) + + call outfld('FLNT'//diag(icall), flnt, pcols, lchnk) + call outfld('FLNTC'//diag(icall), rd%flntc, pcols, lchnk) + + call outfld('FLUT'//diag(icall), rd%flut, pcols, lchnk) + call outfld('FLUTC'//diag(icall), rd%flutc, pcols, lchnk) + + ftem(:ncol) = rd%flutc(:ncol) - rd%flut(:ncol) + call outfld('LWCF'//diag(icall), ftem, pcols, lchnk) + + call outfld('FLN200'//diag(icall), rd%fln200, pcols, lchnk) + call outfld('FLN200C'//diag(icall), rd%fln200c, pcols, lchnk) + + call outfld('FLNR'//diag(icall), rd%flnr, pcols, lchnk) + + call outfld('FLNS'//diag(icall), flns, pcols, lchnk) + call outfld('FLNSC'//diag(icall), rd%flnsc, pcols, lchnk) + + call outfld('FLDS'//diag(icall), cam_out%flwds, pcols, lchnk) + call outfld('FLDSC'//diag(icall), rd%fldsc, pcols, lchnk) + + call outfld('FDL'//diag(icall), rd%flux_lw_dn, pcols, lchnk) + call outfld('FDLC'//diag(icall), rd%flux_lw_clr_dn, pcols, lchnk) + call outfld('FUL'//diag(icall), rd%flux_lw_up, pcols, lchnk) + call outfld('FULC'//diag(icall), rd%flux_lw_clr_up, pcols, lchnk) +end subroutine radiation_output_lw + +!=============================================================================== + +subroutine calc_col_mean(state, mmr_pointer, mean_value) + + ! Compute the column mean mass mixing ratio. + + type(physics_state), intent(in) :: state + real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) + real(r8), dimension(pcols), intent(out) :: mean_value ! column mean mmr + + integer :: i, k, ncol + real(r8) :: ptot(pcols) + !----------------------------------------------------------------------- + + ncol = state%ncol + mean_value = 0.0_r8 + ptot = 0.0_r8 + + do k=1,pver + do i=1,ncol + mean_value(i) = mean_value(i) + mmr_pointer(i,k)*state%pdeldry(i,k) + ptot(i) = ptot(i) + state%pdeldry(i,k) + end do + end do + do i=1,ncol + mean_value(i) = mean_value(i) / ptot(i) + end do + +end subroutine calc_col_mean + +!=============================================================================== + +subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt, tsi_default) + + ! Read data from coefficients file. Initialize the kdist object. + + ! arguments + character(len=*), intent(in) :: coefs_file + class(ty_gas_optics_rrtmgp), intent(out) :: kdist + class(ty_gas_concs), intent(in) :: available_gases ! Which gases does the host model have available? + + real(r8), intent(out), optional :: tsi_default ! RRTMGP reference TSI + + ! local variables + type(file_desc_t) :: fh ! pio file handle + character(len=256) :: locfn ! path to actual file used + + ! File dimensions + integer :: & + absorber, & + atmos_layer, & + bnd, & + pressure, & + temperature, & + absorber_ext, & ! replaces `major_absorber` + pressure_interp, & + mixing_fraction, & + gpt, & + temperature_Planck + + integer :: i, j, k + integer :: did, vid + integer :: ierr + + character(32), dimension(:), allocatable :: gas_names + integer, dimension(:,:,:), allocatable :: key_species + integer, dimension(:,:), allocatable, intent(out) :: band2gpt ! -> file : 'bnd_limits_gpt' + real(r8), dimension(:,:), allocatable :: band_lims_wavenum ! -> file : 'bnd_limits_wavenumber' + real(r8), dimension(:), allocatable :: press_ref, temp_ref + real(r8) :: press_ref_trop, temp_ref_t, temp_ref_p + real(r8), dimension(:,:,:), allocatable :: vmr_ref + real(r8), dimension(:,:,:,:), allocatable :: kmajor + ! ? real(r8), dimension(:,:,:), allocatable :: selfrefin, forrefin + real(r8), dimension(:,:,:), allocatable :: kminor_lower, kminor_upper + real(r8), dimension(:,:), allocatable :: totplnk + real(r8), dimension(:,:,:,:), allocatable :: planck_frac + real(r8), dimension(:), allocatable :: solar_src_quiet, solar_src_facular, solar_src_sunspot ! updated from solar_src + real(r8), dimension(:,:,:), allocatable :: rayl_lower, rayl_upper + character(len=32), dimension(:), allocatable :: gas_minor, & + identifier_minor, & + minor_gases_lower, & + minor_gases_upper, & + scaling_gas_lower, & + scaling_gas_upper + integer, dimension(:,:), allocatable :: minor_limits_gpt_lower, & + minor_limits_gpt_upper + ! Send these to RRTMGP as logicals, + ! but they have to be read from the netCDF as integers + logical, dimension(:), allocatable :: minor_scales_with_density_lower, & + minor_scales_with_density_upper + logical, dimension(:), allocatable :: scale_by_complement_lower, & + scale_by_complement_upper + integer, dimension(:), allocatable :: int2log ! use this to convert integer-to-logical. + integer, dimension(:), allocatable :: kminor_start_lower, kminor_start_upper + real(r8), dimension(:,:), allocatable :: optimal_angle_fit + real(r8) :: mg_default, sb_default + + integer :: pairs, & + minorabsorbers, & + minor_absorber_intervals_lower, & + minor_absorber_intervals_upper, & + contributors_lower, & + contributors_upper, & + fit_coeffs + + character(len=128) :: error_msg + character(len=*), parameter :: sub = 'coefs_init' + !---------------------------------------------------------------------------- + + ! Open file + call getfil(coefs_file, locfn, 0) + call cam_pio_openfile(fh, locfn, PIO_NOWRITE) + + call pio_seterrorhandling(fh, PIO_BCAST_ERROR) + + + ! Get variables and validate them, then put into kdist + + ! Get dimensions and check for consistency with parameter values + + ierr = pio_inq_dimid(fh, 'absorber', did) + if (ierr /= PIO_NOERR) call endrun(sub//': absorber not found') + ierr = pio_inq_dimlen(fh, did, absorber) + + ierr = pio_inq_dimid(fh, 'atmos_layer', did) + if (ierr /= PIO_NOERR) call endrun(sub//': atmos_layer not found') + ierr = pio_inq_dimlen(fh, did, atmos_layer) + + ierr = pio_inq_dimid(fh, 'bnd', did) + if (ierr /= PIO_NOERR) call endrun(sub//': bnd not found') + ierr = pio_inq_dimlen(fh, did, bnd) + + ierr = pio_inq_dimid(fh, 'pressure', did) + if (ierr /= PIO_NOERR) call endrun(sub//': pressure not found') + ierr = pio_inq_dimlen(fh, did, pressure) + + ierr = pio_inq_dimid(fh, 'temperature', did) + if (ierr /= PIO_NOERR) call endrun(sub//': temperature not found') + ierr = pio_inq_dimlen(fh, did, temperature) + + ierr = pio_inq_dimid(fh, 'absorber_ext', did) + if (ierr /= PIO_NOERR) call endrun(sub//': absorber_ext not found') + ierr = pio_inq_dimlen(fh, did, absorber_ext) + + ierr = pio_inq_dimid(fh, 'pressure_interp', did) + if (ierr /= PIO_NOERR) call endrun(sub//': pressure_interp not found') + ierr = pio_inq_dimlen(fh, did, pressure_interp) + + ierr = pio_inq_dimid(fh, 'mixing_fraction', did) + if (ierr /= PIO_NOERR) call endrun(sub//': mixing_fraction not found') + ierr = pio_inq_dimlen(fh, did, mixing_fraction) + + ierr = pio_inq_dimid(fh, 'gpt', did) + if (ierr /= PIO_NOERR) call endrun(sub//': gpt not found') + ierr = pio_inq_dimlen(fh, did, gpt) + + temperature_Planck = 0 + ierr = pio_inq_dimid(fh, 'temperature_Planck', did) + if (ierr == PIO_NOERR) then + ierr = pio_inq_dimlen(fh, did, temperature_Planck) + end if + ierr = pio_inq_dimid(fh, 'pair', did) + if (ierr /= PIO_NOERR) call endrun(sub//': pair not found') + ierr = pio_inq_dimlen(fh, did, pairs) + ierr = pio_inq_dimid(fh, 'minor_absorber', did) + if (ierr /= PIO_NOERR) call endrun(sub//': minor_absorber not found') + ierr = pio_inq_dimlen(fh, did, minorabsorbers) + ierr = pio_inq_dimid(fh, 'minor_absorber_intervals_lower', did) + if (ierr /= PIO_NOERR) call endrun(sub//': minor_absorber_intervals_lower not found') + ierr = pio_inq_dimlen(fh, did, minor_absorber_intervals_lower) + ierr = pio_inq_dimid(fh, 'minor_absorber_intervals_upper', did) + if (ierr /= PIO_NOERR) call endrun(sub//': minor_absorber_intervals_upper not found') + ierr = pio_inq_dimlen(fh, did, minor_absorber_intervals_upper) + ierr = pio_inq_dimid(fh, 'contributors_lower', did) + if (ierr /= PIO_NOERR) call endrun(sub//': contributors_lower not found') + ierr = pio_inq_dimlen(fh, did, contributors_lower) + ierr = pio_inq_dimid(fh, 'contributors_upper', did) + if (ierr /= PIO_NOERR) call endrun(sub//': contributors_upper not found') + ierr = pio_inq_dimlen(fh, did, contributors_upper) + + ierr = pio_inq_dimid(fh, 'fit_coeffs', did) + if (ierr == PIO_NOERR) then + ierr = pio_inq_dimlen(fh, did, fit_coeffs) + end if + + + ! Get variables + + ! names of absorbing gases + allocate(gas_names(absorber)) + 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)) + 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)) + 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)) + 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)) + 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) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading press_ref') + + ! reference pressure separating the lower and upper atmosphere + ierr = pio_inq_varid(fh, 'press_ref_trop', vid) + if (ierr /= PIO_NOERR) call endrun(sub//': press_ref_trop not found') + ierr = pio_get_var(fh, vid, press_ref_trop) + 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)) + 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) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading temp_ref') + + ! standard spectroscopic reference temperature [K] + ierr = pio_inq_varid(fh, 'absorption_coefficient_ref_T', vid) + if (ierr /= PIO_NOERR) call endrun(sub//': absorption_coefficient_ref_T not found') + ierr = pio_get_var(fh, vid, temp_ref_t) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading absorption_coefficient_ref_T') + + ! standard spectroscopic reference pressure [hPa] + ierr = pio_inq_varid(fh, 'absorption_coefficient_ref_P', vid) + if (ierr /= PIO_NOERR) call endrun(sub//': absorption_coefficient_ref_P not found') + ierr = pio_get_var(fh, vid, temp_ref_p) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading absorption_coefficient_ref_P') + + ! volume mixing ratios for reference atmosphere + ! vmr_ref(temperature, absorber_ext, atmos_layer) + allocate(vmr_ref(atmos_layer, absorber_ext, temperature)) + 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)) + 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') + + ! -bpm - variable wv_self & wv_for not in the newer files. + ! ! absorption coefficients due to water vapor self continuum + ! allocate(selfrefin(gpt,mixing_fraction,temperature)) + ! ierr = pio_inq_varid(fh, 'wv_self', vid) + ! if (ierr /= PIO_NOERR) call endrun(sub//': wv_self not found') + ! ierr = pio_get_var(fh, vid, selfrefin) + ! if (ierr /= PIO_NOERR) call endrun(sub//': error reading wv_self') + + ! ! absorption coefficients due to water vapor foreign continuum + ! allocate(forrefin(gpt,mixing_fraction,temperature)) + ! ierr = pio_inq_varid(fh, 'wv_for', vid) + ! if (ierr /= PIO_NOERR) call endrun(sub//': wv_for not found') + ! ierr = pio_get_var(fh, vid, forrefin) + ! if (ierr /= PIO_NOERR) call endrun(sub//': error reading wv_for') + + ! absorption coefficients due to minor absorbing gases in lower part of atmosphere + allocate(kminor_lower(contributors_lower, mixing_fraction, temperature)) + 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)) + 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) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading kminor_upper') + + ! integrated Planck function by band + ierr = pio_inq_varid(fh, 'totplnk', vid) + if (ierr == PIO_NOERR) then + allocate(totplnk(temperature_Planck,bnd)) + ierr = pio_get_var(fh, vid, totplnk) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading totplnk') + end if + + ! Planck fractions + ierr = pio_inq_varid(fh, 'plank_fraction', vid) + if (ierr == PIO_NOERR) then + allocate(planck_frac(gpt,mixing_fraction,pressure_interp,temperature)) + 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)) + ierr = pio_get_var(fh, vid, optimal_angle_fit) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading optimal_angle_fit') + end if + + ! solar_src + ! !bpm -- solar_source is not in file, there are solar_source_[facular, sunspot, quiet] + ! There's a method that adds them together to get solar_source. + ! ierr = pio_inq_varid(fh, 'solar_source', vid) + ! if (ierr == PIO_NOERR) then + ! allocate(solar_src(gpt)) + ! ierr = pio_get_var(fh, vid, solar_src) + ! if (ierr /= PIO_NOERR) call endrun(sub//': error reading solar_source') + ! end if + ierr = pio_inq_varid(fh, 'solar_source_quiet', vid) + if (ierr == PIO_NOERR) then + allocate(solar_src_quiet(gpt)) + 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)) + 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)) + ierr = pio_get_var(fh, vid, solar_src_sunspot) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading solar_source_sunspot') + end if + + ! +bpm also need to have tsi_default, mg_default, and sb_default + ierr = pio_inq_varid(fh, 'tsi_default', vid) + if (ierr == PIO_NOERR) then + ierr = pio_get_var(fh, vid, tsi_default) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading tsi_default') + end if + + ierr = pio_inq_varid(fh, 'mg_default', vid) + if (ierr == PIO_NOERR) then + ierr = pio_get_var(fh, vid, mg_default) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading mg_default') + end if + + ierr = pio_inq_varid(fh, 'sb_default', vid) + if (ierr == PIO_NOERR) then + ierr = pio_get_var(fh, vid, sb_default) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading sb_default') + end if + + ! 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)) + ierr = pio_get_var(fh, vid, rayl_lower) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading rayl_lower') + end if + + ! 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)) + ierr = pio_get_var(fh, vid, rayl_upper) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading rayl_upper') + end if + + ! +bpm the others + allocate(gas_minor(minorabsorbers)) + 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)) + 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)) + 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)) + 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)) + 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)) + 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)) + 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) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading minor_scales_with_density_lower') + do i = 1,minor_absorber_intervals_lower + if (int2log(i) .eq. 0) then + minor_scales_with_density_lower(i) = .false. + else + minor_scales_with_density_lower(i) = .true. + end if + end do + 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)) + 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) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading minor_scales_with_density_upper') + do i = 1,minor_absorber_intervals_upper + if (int2log(i) .eq. 0) then + minor_scales_with_density_upper(i) = .false. + else + minor_scales_with_density_upper(i) = .true. + end if + end do + deallocate(int2log) + + ! Read as integer and convert to logical + allocate(int2log(minor_absorber_intervals_lower)) + allocate(scale_by_complement_lower(minor_absorber_intervals_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) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading scale_by_complement_lower') + do i = 1,minor_absorber_intervals_lower + if (int2log(i) .eq. 0) then + scale_by_complement_lower(i) = .false. + else + scale_by_complement_lower(i) = .true. + end if + end do + deallocate(int2log) + + ! Read as integer and convert to logical + allocate(int2log(minor_absorber_intervals_upper)) + allocate(scale_by_complement_upper(minor_absorber_intervals_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) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading scale_by_complement_upper') + do i = 1,minor_absorber_intervals_upper + if (int2log(i) .eq. 0) then + scale_by_complement_upper(i) = .false. + else + scale_by_complement_upper(i) = .true. + end if + end do + deallocate(int2log) + + allocate(scaling_gas_lower(minor_absorber_intervals_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)) + 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)) + 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)) + 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) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading kminor_start_upper') + + ! Close file + call pio_closefile(fh) + + ! Initialize the gas optics class with data. The calls look slightly different depending + ! on whether the radiation sources are internal to the atmosphere (longwave) or external (shortwave) + ! gas_optics%load() returns a string; a non-empty string indicates an error. + ! + if (allocated(totplnk) .and. allocated(planck_frac)) then + error_msg = kdist%load(available_gases, gas_names, key_species, & + band2gpt, & + band_lims_wavenum, & + press_ref, & + press_ref_trop, & + temp_ref, & + temp_ref_p, & + temp_ref_t, & + vmr_ref, & + kmajor, & + kminor_lower, & + kminor_upper, & + gas_minor, & + identifier_minor, & + minor_gases_lower, & + minor_gases_upper, & + minor_limits_gpt_lower, & + minor_limits_gpt_upper, & + minor_scales_with_density_lower, & + minor_scales_with_density_upper, & + scaling_gas_lower, & + scaling_gas_upper, & + scale_by_complement_lower, & + scale_by_complement_upper, & + kminor_start_lower, & + kminor_start_upper, & + totplnk, planck_frac, & + rayl_lower, rayl_upper, & + optimal_angle_fit) + else if (allocated(solar_src_quiet)) then + error_msg = kdist%load(available_gases, & + gas_names, & + key_species, & + band2gpt, & + band_lims_wavenum, & + press_ref, & + press_ref_trop, & + temp_ref, & + temp_ref_p, & + temp_ref_t, & + vmr_ref, & + kmajor, & + kminor_lower, & + kminor_upper, & + gas_minor, & + identifier_minor, & + minor_gases_lower, & + minor_gases_upper, & + minor_limits_gpt_lower, & + minor_limits_gpt_upper, & + minor_scales_with_density_lower, & + minor_scales_with_density_upper, & + scaling_gas_lower, & + scaling_gas_upper, & + scale_by_complement_lower, & + scale_by_complement_upper, & + kminor_start_lower, & + kminor_start_upper, & + solar_src_quiet, & + solar_src_facular, & + solar_src_sunspot, & + tsi_default, & + mg_default, & + sb_default, & + rayl_lower, & + rayl_upper) + else + error_msg = 'must supply either totplnk and planck_frac, or solar_src_[*]' + end if + + if (len_trim(error_msg) > 0) then + call endrun(sub//': ERROR: '//trim(error_msg)) + end if + + deallocate( & + gas_names, key_species, & + band_lims_wavenum, & + press_ref, temp_ref, vmr_ref, & + 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, & + kminor_start_lower, kminor_start_upper) + ! did not deallocate band2gpt because we want to use it later (changed it to intent(out), bpm) + 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) +end subroutine coefs_init + + + +subroutine set_available_gases(gases, gas_concentrations) + ! This subroutine is based on the E3SM implementation. -bpm + ! For each gas name in gases, initialize that gas in gas_concentrations. + use mo_gas_concentrations, only: ty_gas_concs + use mo_rrtmgp_util_string, only: lower_case + ! Arguments + type(ty_gas_concs), intent(inout) :: gas_concentrations + character(len=*), intent(in) :: gases(:) + ! Local + character(len=32), dimension(size(gases)) :: gases_lowercase + integer :: igas + character(len=128) :: error_msg + ! Initialize with lowercase gas names; we should work in lowercase + ! whenever possible because we cannot trust string comparisons in RRTMGP + ! to be case insensitive ... it *should* work regardless of case. + do igas = 1,size(gases) + gases_lowercase(igas) = trim(lower_case(gases(igas))) + end do + error_msg = gas_concentrations%init(gases_lowercase) + if (len_trim(error_msg) > 0) then + call endrun('Setting available gases. ERROR: '//trim(error_msg)) + end if +end subroutine set_available_gases + + +subroutine reset_fluxes(fluxes) + + use mo_fluxes_byband, only: ty_fluxes_byband + type(ty_fluxes_byband), intent(inout) :: fluxes + + ! Reset broadband fluxes + fluxes%flux_up(:,:) = 0._r8 + fluxes%flux_dn(:,:) = 0._r8 + fluxes%flux_net(:,:) = 0._r8 + if (associated(fluxes%flux_dn_dir)) then + fluxes%flux_dn_dir(:,:) = 0._r8 + end if + + ! Reset band-by-band fluxes + fluxes%bnd_flux_up(:,:,:) = 0._r8 + fluxes%bnd_flux_dn(:,:,:) = 0._r8 + fluxes%bnd_flux_net(:,:,:) = 0._r8 + if (associated(fluxes%bnd_flux_dn_dir)) then + fluxes%bnd_flux_dn_dir(:,:,:) = 0._r8 + end if + +end subroutine reset_fluxes + + +subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct) + ! This closely follows the E3SM implementation. + use mo_fluxes_byband, only: ty_fluxes_byband + integer, intent(in) :: ncol, nlevels, nbands + type(ty_fluxes_byband), intent(inout) :: fluxes + logical, intent(in), optional :: do_direct + + logical :: do_direct_local + + if (present(do_direct)) then + do_direct_local = .true. + else + do_direct_local = .false. + end if + + ! Allocate flux arrays + ! NOTE: fluxes defined at interfaces, so need to either pass nlevels as + ! number of model levels plus one, or allocate as nlevels+1 if nlevels + ! represents number of model levels rather than number of interface levels. + + ! 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)) + + ! 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)) + + ! Initialize + call reset_fluxes(fluxes) + +end subroutine initialize_rrtmgp_fluxes + + +subroutine initialize_rrtmgp_cloud_optics_sw(ncol, nlevels, kdist, optics) + ! use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp ! module level + use mo_optical_props, only: ty_optical_props_2str + + integer, intent(in) :: ncol, nlevels + type(ty_gas_optics_rrtmgp), intent(in) :: kdist + type(ty_optical_props_2str), intent(out) :: optics + + integer :: ngpt + character(len=128) :: errmsg + character(len=128) :: sub = 'initialize_rrtmgp_cloud_optics_sw' + + ! ngpt = kdist%get_ngpt() + + errmsg = optics%alloc_2str(ncol, nlevels, kdist, name='shortwave cloud optics') + if (len_trim(errmsg) > 0) then + call endrun(trim(sub)//': ERROR: optics%alloc_2str: '//trim(errmsg)) + end if + ! these are all expected to be shape (ncol, nlay, ngpt) + optics%tau = 0.0_r8 + optics%ssa = 1.0_r8 + optics%g = 0.0_r8 +end subroutine initialize_rrtmgp_cloud_optics_sw + + +subroutine initialize_rrtmgp_cloud_optics_lw(ncol, nlevels, kdist, optics) + ! use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp ! module level + use mo_optical_props, only: ty_optical_props_1scl + + integer, intent(in) :: ncol, nlevels + type(ty_gas_optics_rrtmgp), intent(in) :: kdist + type(ty_optical_props_1scl), intent(out) :: optics + + integer :: ngpt + character(len=128) :: errmsg + character(len=128) :: sub = 'initialize_rrtmgp_cloud_optics_lw' + + ngpt = kdist%get_ngpt() + errmsg =optics%alloc_1scl(ncol, nlevels, kdist, name='longwave cloud optics') + if (len_trim(errmsg) > 0) then + call endrun(trim(sub)//': ERROR: optics%init_1scalar: '//trim(errmsg)) + end if + optics%tau(:ncol, :nlevels, :ngpt) = 0.0 + +end subroutine initialize_rrtmgp_cloud_optics_lw + + +subroutine free_optics_sw(optics) + use mo_optical_props, only: ty_optical_props_2str + type(ty_optical_props_2str), intent(inout) :: optics + if (allocated(optics%tau)) deallocate(optics%tau) + if (allocated(optics%ssa)) deallocate(optics%ssa) + if (allocated(optics%g)) deallocate(optics%g) + call optics%finalize() +end subroutine free_optics_sw + + +subroutine free_optics_lw(optics) + use mo_optical_props, only: ty_optical_props_1scl + type(ty_optical_props_1scl), intent(inout) :: optics + if (allocated(optics%tau)) deallocate(optics%tau) + call optics%finalize() +end subroutine free_optics_lw + + +subroutine free_fluxes(fluxes) + use mo_fluxes_byband, only: ty_fluxes_byband + type(ty_fluxes_byband), intent(inout) :: fluxes + if (associated(fluxes%flux_up)) deallocate(fluxes%flux_up) + if (associated(fluxes%flux_dn)) deallocate(fluxes%flux_dn) + if (associated(fluxes%flux_net)) deallocate(fluxes%flux_net) + if (associated(fluxes%flux_dn_dir)) deallocate(fluxes%flux_dn_dir) + if (associated(fluxes%bnd_flux_up)) deallocate(fluxes%bnd_flux_up) + if (associated(fluxes%bnd_flux_dn)) deallocate(fluxes%bnd_flux_dn) + if (associated(fluxes%bnd_flux_net)) deallocate(fluxes%bnd_flux_net) + if (associated(fluxes%bnd_flux_dn_dir)) deallocate(fluxes%bnd_flux_dn_dir) +end subroutine free_fluxes + + +subroutine modified_cloud_fraction(cld, cldfsnow, cldfgrau, cldfsnow_idx, cldfgrau_idx, cldfprime) + real(r8), pointer :: cld(:,:) ! cloud fraction + real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds"- whatever they are + real(r8), pointer :: cldfgrau(:,:) ! cloud fraction of just "graupel clouds"- whatever they are + integer, intent(in) :: cldfsnow_idx ! physics buffer index for snow cloud fraction + integer, intent(in) :: cldfgrau_idx ! physics buffer index for graupel cloud fraction + real(r8), intent(inout) :: cldfprime(:,:) ! combined cloud fraction (snow plus regular) + integer :: k,i,ncol,nlev + + ! graupel_in_rad is module data from namelist. + ! pcols is "physics columns" and comes from module data. + ! pver is "physics vertical levels" and comes from module data. + + ! 1. initialize as cld + ! 2. check whether to modify for snow, where snow is, use max(cld, cldfsnow) + ! 3. check whether to modify for graupel, where graupel, use max(cldfprime, cldfgrau) + ! -- use cldfprime as it will already be modified for snow if necessary, and equal to cld if not. + + ncol = size(cld,1) + nlev = size(cld,2) + cldfprime(1:ncol, 1:nlev) = cld(1:ncol, 1:nlev) ! originally nlev here was pver + + if (cldfsnow_idx > 0) then + do k = 1, nlev + do i = 1, ncol + cldfprime(i,k) = max(cld(i,k), cldfsnow(i,k)) + end do + end do + else + cldfprime(:ncol,:) = cld(:ncol,:) + end if + + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + do k = 1, nlev + do i = 1, ncol + cldfprime(i,k) = max(cldfprime(i,k), cldfgrau(i,k)) + end do + end do + end if + +end subroutine modified_cloud_fraction + +! +! a simple clipping subroutine +! +elemental subroutine clipper(scalar, minval, maxval) + real(r8), intent(inout) :: scalar + real(r8), intent(in) :: minval, maxval + if (minval < maxval) then + if (scalar < minval) then + scalar = minval + end if + if (scalar > maxval) then + scalar = maxval + end if + end if +end subroutine clipper + + +end module radiation + diff --git a/src/physics/rrtmgp/rrtmgp_driver.F90 b/src/physics/rrtmgp/rrtmgp_driver.F90 new file mode 100644 index 0000000000..12f16e7b5c --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_driver.F90 @@ -0,0 +1,386 @@ +! This code is based closely on mo_rrtmgp_clr_all_sky.F90 from +! RRTM for GCM Applications - Parallel (RRTMGP) +! +! Eli Mlawer and Robert Pincus +! Andre Wehe and Jennifer Delamere +! email: rrtmgp@aer.com +! +! Copyright 2017, Atmospheric and Environmental Research and +! Regents of the University of Colorado. All right reserved. +! +! Use and duplication is permitted under the terms of the +! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause +! + +! +! This module provides an interface to RRTMGP for a common use case -- +! users want to start from gas concentrations, pressures, and temperatures, +! and compute clear-sky (aerosol plus gases) and all-sky fluxes. +! The routines here have the same names as those in mo_rrtmgp_[ls]w; normally users +! will use either this module or the underling modules, but not both +! +module rrtmgp_driver + use mo_rte_kind, only: wp + ! use mo_gas_optics, only: ty_gas_optics ! replacing this with _rrtmgp version + + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + + use mo_gas_concentrations, only: ty_gas_concs + use mo_optical_props, only: ty_optical_props, & + ty_optical_props_arry, & + ty_optical_props_1scl, & + ty_optical_props_2str, & + ty_optical_props_nstr + use mo_source_functions, only: ty_source_func_lw + ! use mo_fluxes, only: ty_fluxes ! not needed b/c mo_fluxes_byband extends this type + use mo_fluxes_byband, only: ty_fluxes_byband + use mo_rte_lw, only: base_rte_lw => rte_lw + use mo_rte_sw, only: base_rte_sw => rte_sw + + use cam_logfile, only: iulog + + implicit none + private + + public :: rte_lw, rte_sw +contains + ! -------------------------------------------------- + ! + ! Interfaces using clear (gas + aerosol) and all-sky categories, starting from + ! pressures, temperatures, and gas amounts for the gas contribution + ! + ! -------------------------------------------------- + function rte_lw(k_dist, gas_concs, p_lay, t_lay, p_lev, & + t_sfc, sfc_emis, cloud_props, & + allsky_fluxes, clrsky_fluxes, & + aer_props, col_dry, t_lev, inc_flux, n_gauss_angles) result(error_msg) + ! class(ty_gas_optics), intent(in ) :: k_dist !< derived type with spectral information + class(ty_gas_optics_rrtmgp), intent(in ) :: k_dist !< derived type with spectral information + + type(ty_gas_concs), intent(in ) :: gas_concs !< derived type encapsulating gas concentrations + real(wp), dimension(:,:), intent(in ) :: p_lay, t_lay !< pressure [Pa], temperature [K] at layer centers (ncol,nlay) + real(wp), dimension(:,:), intent(in ) :: p_lev !< pressure at levels/interfaces [Pa] (ncol,nlay+1) + real(wp), dimension(:), intent(in ) :: t_sfc !< surface temperature [K] (ncol) + real(wp), dimension(:,:), intent(in ) :: sfc_emis !< emissivity at surface [] (nband, ncol) + class(ty_optical_props_arry), intent(in ) :: cloud_props !< cloud optical properties (ncol,nlay,ngpt) + class(ty_fluxes_byband), intent(inout) :: allsky_fluxes, clrsky_fluxes ! 3/21 - _byband bpm + + ! Optional inputs + class(ty_optical_props_arry), & + optional, intent(in ) :: aer_props !< aerosol optical properties + real(wp), dimension(:,:), & + optional, intent(in ) :: col_dry !< Molecular number density (ncol, nlay) + real(wp), dimension(:,:), target, & + optional, intent(in ) :: t_lev !< temperature at levels [K] (ncol, nlay+1) + real(wp), dimension(:,:), target, & + optional, intent(in ) :: inc_flux !< incident flux at domain top [W/m2] (ncol, ngpts) + integer, optional, intent(in ) :: n_gauss_angles ! Number of angles used in Gaussian quadrature (no-scattering solution) + character(len=128) :: error_msg + ! -------------------------------- + ! Local variables + ! + class(ty_optical_props_arry), allocatable :: optical_props + type(ty_source_func_lw) :: sources + + integer :: ncol, nlay, ngpt, nband, nstr + logical :: top_at_1 + ! -------------------------------- + ! Problem sizes + ! + + error_msg = "" + + ncol = size(p_lay, 1) + nlay = size(p_lay, 2) + ngpt = k_dist%get_ngpt() + nband = k_dist%get_nband() + + !$acc kernels copyout(top_at_1) + !$omp target map(from:top_at_1) + top_at_1 = p_lay(1, 1) < p_lay(1, nlay) + !$acc end kernels + !$omp end target + + ! ------------------------------------------------------------------------------------ + ! Error checking + ! + if(present(aer_props)) then + if(any([aer_props%get_ncol(), & + aer_props%get_nlay()] /= [ncol, nlay])) & + error_msg = "rrtmpg_lw: aerosol properties inconsistently sized" + if(.not. any(aer_props%get_ngpt() /= [ngpt, nband])) & + error_msg = "rrtmpg_lw: aerosol properties inconsistently sized" + end if + + if(present(t_lev)) then + if(any([size(t_lev, 1), & + size(t_lev, 2)] /= [ncol, nlay+1])) & + error_msg = "rrtmpg_lw: t_lev inconsistently sized" + end if + + if(present(inc_flux)) then + if(any([size(inc_flux, 1), & + size(inc_flux, 2)] /= [ncol, ngpt])) & + error_msg = "rrtmpg_lw: incident flux inconsistently sized" + end if + if(len_trim(error_msg) > 0) return + + ! ------------------------------------------------------------------------------------ + ! Optical properties arrays + ! + select type(cloud_props) + class is (ty_optical_props_1scl) ! No scattering + allocate(ty_optical_props_1scl::optical_props) + class is (ty_optical_props_2str) + allocate(ty_optical_props_2str::optical_props) + class is (ty_optical_props_nstr) + allocate(ty_optical_props_nstr::optical_props) + nstr = size(cloud_props%tau,1) + end select + + error_msg = optical_props%init(k_dist) + + if(len_trim(error_msg) > 0) return + select type (optical_props) + class is (ty_optical_props_1scl) ! No scattering + error_msg = optical_props%alloc_1scl(ncol, nlay) + class is (ty_optical_props_2str) + error_msg = optical_props%alloc_2str(ncol, nlay) + class is (ty_optical_props_nstr) + error_msg = optical_props%alloc_nstr(nstr, ncol, nlay) + end select + if (error_msg /= '') return + + ! + ! Source function + ! + error_msg = sources%init(k_dist) + error_msg = sources%alloc(ncol, nlay) + if (error_msg /= '') return + + ! ------------------------------------------------------------------------------------ + ! Clear skies + ! + ! Gas optical depth -- pressure need to be expressed as Pa + ! + error_msg = k_dist%gas_optics(p_lay, p_lev, t_lay, t_sfc, gas_concs, & + optical_props, sources) !, & + ! col_dry, t_lev) + ! col_dry & t_lev are optional, and we have not provided them. + if (error_msg /= '') then + return + end if + + ! ---------------------------------------------------- + ! Clear sky is gases + aerosols (if they're supplied) + ! + if (present(aer_props)) then + error_msg = aer_props%increment(optical_props) + end if + if (error_msg /= '') then + return + end if + + error_msg = base_rte_lw(optical_props, top_at_1, sources, & + sfc_emis, clrsky_fluxes, & + inc_flux, n_gauss_angles) + if (error_msg /= '') then + return + end if + + ! ------------------------------------------------------------------------------------ + ! All-sky fluxes = clear skies + clouds + ! + error_msg = cloud_props%increment(optical_props) + if(error_msg /= '') return + + error_msg = base_rte_lw(optical_props, top_at_1, sources, & + sfc_emis, allsky_fluxes, & + inc_flux, n_gauss_angles) + + call sources%finalize() + call optical_props%finalize() + + end function rte_lw + ! -------------------------------------------------- + ! -------------------------------------------------- + ! -------------------------------------------------- + function rte_sw(k_dist, & + gas_concs, & + p_lay, & + t_lay, & + p_lev, & + mu0, & + sfc_alb_dir, & + sfc_alb_dif, & + cloud_props, & + allsky_fluxes, & + clrsky_fluxes, & + aer_props, & + col_dry, & + inc_flux, & !< optional input: total solar irradiance (ncol, ngpt) + tsi_scaling, & !< optional input: scalar scaling factor for TSI + tsi_scaling_gpt & !< optional input: scaling for TSI by gpt + ) result(error_msg) + class(ty_gas_optics_rrtmgp), intent(in ) :: k_dist !< derived type with spectral information + + type(ty_gas_concs), intent(in ) :: gas_concs !< derived type encapsulating gas concentrations + real(wp), dimension(:,:), intent(in ) :: p_lay, t_lay !< pressure [Pa], temperature [K] at layer centers (ncol,nlay) + real(wp), dimension(:,:), intent(in ) :: p_lev !< pressure at levels/interfaces [Pa] (ncol,nlay+1) + real(wp), dimension(: ), intent(in ) :: mu0 !< cosine of solar zenith angle + real(wp), dimension(:,:), intent(in ) :: sfc_alb_dir, sfc_alb_dif + ! surface albedo for direct and diffuse radiation (band, col) + class(ty_optical_props_arry), intent(in ) :: cloud_props !< cloud optical properties (ncol,nlay,ngpt) + class(ty_fluxes_byband), intent(inout) :: allsky_fluxes, clrsky_fluxes + + ! Optional inputs + class(ty_optical_props_arry), target, & + optional, intent(in ) :: aer_props !< aerosol optical properties + real(wp), dimension(:,:), & + optional, intent(in ) :: col_dry, & !< Molecular number density (ncol, nlay) + inc_flux !< incident flux at domain top [W/m2] (ncol, ngpts) + real(wp), optional, intent(in ) :: tsi_scaling !< Optional scaling for total solar irradiance (SCALAR) + real(wp), dimension(:), optional, intent(in ) :: tsi_scaling_gpt !< Optional scaling of solar irradiance by gpoint + + + character(len=128) :: error_msg + ! -------------------------------- + ! Local variables + ! + class(ty_optical_props_arry), allocatable :: optical_props + real(wp), dimension(:,:), allocatable :: toa_flux + integer :: ncol, nlay, ngpt, nband, nstr + integer :: icol + logical :: top_at_1 + ! -------------------------------- + ! Problem sizes + ! + + error_msg = "" + + ncol = size(p_lay, 1) + nlay = size(p_lay, 2) + ngpt = k_dist%get_ngpt() + nband = k_dist%get_nband() + + top_at_1 = p_lay(1, 1) < p_lay(1, nlay) + + ! ------------------------------------------------------------------------------------ + ! Error checking + ! + if(present(aer_props)) then + if(any([aer_props%get_ncol(), & + aer_props%get_nlay()] /= [ncol, nlay])) & + error_msg = "rrtmgp_driver rte_sw: aerosol properties inconsistently sized" + if(.not. any(aer_props%get_ngpt() /= [ngpt, nband])) & + error_msg = "rrtmgp_driver rte_sw: aerosol properties inconsistently sized" + end if + + if (present(tsi_scaling) .and. (present(tsi_scaling_gpt))) then + error_msg = "rrtmgp_driver rte_sw: Only one of [tsi_scaling, tsi_scaling_gpt] may be specified." + end if + + if(present(tsi_scaling)) then + if(tsi_scaling <= 0._wp) then + error_msg = "rrtmgp_driver rte_sw: tsi_scaling is < 0" + end if + end if + + if(present(inc_flux)) then + if(any([size(inc_flux, 1), size(inc_flux, 2)] /= [ncol, ngpt])) then + error_msg = "rrtmgp_driver rte_sw: incident flux inconsistently sized" + end if + end if + if(len_trim(error_msg) > 0) return + + ! ------------------------------------------------------------------------------------ + ! + ! Optical properties arrays + ! + select type(cloud_props) + class is (ty_optical_props_1scl) ! No scattering + allocate(ty_optical_props_1scl::optical_props) + class is (ty_optical_props_2str) + allocate(ty_optical_props_2str::optical_props) + class is (ty_optical_props_nstr) + allocate(ty_optical_props_nstr::optical_props) + nstr = cloud_props%get_nmom() + end select + + error_msg = optical_props%init(k_dist%get_band_lims_wavenumber(), & + k_dist%get_band_lims_gpoint()) + if(len_trim(error_msg) > 0) return + select type (optical_props) + class is (ty_optical_props_1scl) ! No scattering + error_msg = optical_props%alloc_1scl(ncol, nlay) + class is (ty_optical_props_2str) + error_msg = optical_props%alloc_2str(ncol, nlay) + class is (ty_optical_props_nstr) + error_msg = optical_props%alloc_nstr(nstr, ncol, nlay) + end select + if (error_msg /= '') return + + allocate(toa_flux(ncol, ngpt)) + ! ------------------------------------------------------------------------------------ + ! Clear skies + ! + ! Gas optical depth -- pressure need to be expressed as Pa + ! + error_msg = k_dist%gas_optics(p_lay, p_lev, t_lay, gas_concs, & + optical_props, toa_flux) ! , & + ! col_dry) + ! col_dry is optional and we have not provided it. + if (error_msg /= '') return + ! + ! If users have supplied an incident flux, use that + ! + if (present(inc_flux)) then + toa_flux(:,:) = inc_flux(:,:) + end if + ! + ! If there is a scaling provided, apply it + ! + if(present(tsi_scaling)) toa_flux(:,:) = toa_flux(:,:) * tsi_scaling + + if(present(tsi_scaling_gpt)) then + do icol = 1,ncol + toa_flux(icol,:) = toa_flux(icol,:) * tsi_scaling_gpt + end do + end if + ! ---------------------------------------------------- + ! Clear sky is gases + aerosols (if they're supplied) + ! + if(present(aer_props)) error_msg = aer_props%increment(optical_props) + if(error_msg /= '') return + + error_msg = base_rte_sw(optical_props, top_at_1, & + mu0, toa_flux, & + sfc_alb_dir, sfc_alb_dif, & + clrsky_fluxes) + + if(error_msg /= '') return + ! ------------------------------------------------------------------------------------ + ! All-sky fluxes = clear skies + clouds + ! + error_msg = cloud_props%increment(optical_props) + if (error_msg /= '') then + return + end if + + error_msg = base_rte_sw(optical_props, & ! (in) Optical properties provided as arrays + top_at_1, & ! (in) Is the top of the domain at index 1? + mu0, & ! (in) cosine of solar zenith angle (ncol) + toa_flux, & ! (in) incident flux at top of domain [W/m2] (ncol, ngpt) + sfc_alb_dir, & ! (in) surface albedo, direct (nband, ncol) + sfc_alb_dif, & ! (in) surface albedo, diffuse (nband, ncol) + allsky_fluxes & ! (inout) Class describing output calculations (ty_fluxes_byband) + ) + + + call optical_props%finalize() + if (allocated(toa_flux)) then + deallocate(toa_flux) + end if + end function rte_sw + +end module rrtmgp_driver diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 new file mode 100644 index 0000000000..90d87fcf07 --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -0,0 +1,838 @@ +module rrtmgp_inputs + +!-------------------------------------------------------------------------------- +! Transform data for state inputs from CAM's data structures to those used by +! RRTMGP. Subset the number of model levels if CAM's top exceeds RRTMGP's +! valid domain. +! +! This code is currently set up to send RRTMGP vertical layers ordered bottom +! to top of model. Although the RRTMGP is supposed to be agnostic about the +! vertical ordering problems have arisen trying to use the top to bottom order +! as used by CAM's infrastructure. +! +!-------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use ppgrid, only: pcols, pver, pverp + +use physconst, only: stebol + +use physics_types, only: physics_state +use physics_buffer, only: physics_buffer_desc +use camsrfexch, only: cam_in_t + +use radconstants, only: get_ref_solar_band_irrad, rad_gas_index +use radconstants, only: nradgas, gaslist, rrtmg_to_rrtmgp_swbands +use rad_solar_var, only: get_variability +use solar_irrad_data, only : do_spctrl_scaling, sol_tsi +use rad_constituents, only: rad_cnst_get_gas + +use mcica_subcol_gen, only: mcica_subcol_sw, mcica_subcol_lw + +use mo_gas_concentrations, only: ty_gas_concs +use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp +use mo_optical_props, only: ty_optical_props, ty_optical_props_2str, ty_optical_props_1scl + +! unneeded use mo_rrtmgp_util_string, only: lower_case +use cam_logfile, only: iulog +use cam_abortutils, only: endrun + +use cam_history, only: outfld ! just for getting ozone VMR above model top. +use b_checker, only: assert_shape ! checking on shapes + +implicit none +private +save + +public :: & + rrtmgp_inputs_init, & + rrtmgp_set_state, & + rrtmgp_set_gases_lw, & + rrtmgp_set_gases_sw, & + rrtmgp_set_cloud_lw, & + rrtmgp_set_cloud_sw, & + rrtmgp_set_aer_lw, & + rrtmgp_set_aer_sw + +real(r8), parameter :: cldmin = 1.0e-80_r8 ! min cloud fraction + +real(r8), parameter :: amdw = 1.607793_r8 ! Molecular weight of dry air / water vapor +real(r8), parameter :: amdc = 0.658114_r8 ! Molecular weight of dry air / carbon dioxide +real(r8), parameter :: amdo = 0.603428_r8 ! Molecular weight of dry air / ozone +real(r8), parameter :: amdm = 1.805423_r8 ! Molecular weight of dry air / methane +real(r8), parameter :: amdn = 0.658090_r8 ! Molecular weight of dry air / nitrous oxide +real(r8), parameter :: amdo2 = 0.905140_r8 ! Molecular weight of dry air / oxygen +real(r8), parameter :: amdc1 = 0.210852_r8 ! Molecular weight of dry air / CFC11 +real(r8), parameter :: amdc2 = 0.239546_r8 ! Molecular weight of dry air / CFC12 + +! Indices for copying data between cam and rrtmgp arrays +! Assume the rrtmgp vertical index goes bottom to top of atm +integer :: ktopcamm ! cam index of top layer +integer :: ktopradm ! rrtmgp index of layer corresponding to ktopcamm +integer :: ktopcami ! cam index of top interface +integer :: ktopradi ! rrtmgp index of interface corresponding to ktopcami + +!================================================================================================== +contains +!================================================================================================== + +subroutine rrtmgp_inputs_init(ktcamm, ktradm, ktcami, ktradi) + + integer, intent(in) :: ktcamm + integer, intent(in) :: ktradm + integer, intent(in) :: ktcami + integer, intent(in) :: ktradi + + ktopcamm = ktcamm + ktopradm = ktradm + ktopcami = ktcami + ktopradi = ktradi + +end subroutine rrtmgp_inputs_init + +!================================================================================================== + +subroutine rrtmgp_set_state( & + pstate, cam_in, ncol, nlay, nlwbands, & + nswbands, ngpt_sw, nday, idxday, coszrs, & + kdist_sw, & ! eccf, & !!! Removing eccf from arguments, as it is not needed here + band2gpt_sw, & + t_sfc, emis_sfc, t_rad, & + pmid_rad, pint_rad, t_day, pmid_day, pint_day, & + coszrs_day, alb_dir, alb_dif, tsi) + + ! arguments + type(physics_state), target, intent(in) :: pstate + type(cam_in_t), intent(in) :: cam_in + integer, intent(in) :: ncol + integer, intent(in) :: nlay + integer, intent(in) :: nlwbands + integer, intent(in) :: nswbands + integer, intent(in) :: ngpt_sw + integer, intent(in) :: nday + integer, intent(in) :: idxday(:) + real(r8), intent(in) :: coszrs(:) + ! real(r8), intent(in) :: eccf ! Earth orbit eccentricity factor + integer, intent(in) :: band2gpt_sw(:,:) !< (2, nswbands) + + class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! spectral information +!!! CHECK pcols vs ncol !!! + real(r8), intent(out) :: t_sfc(ncol) ! surface temperature [K] + real(r8), intent(out) :: emis_sfc(nlwbands,ncol) ! emissivity at surface [] + real(r8), intent(out) :: t_rad(ncol,nlay) ! layer midpoint temperatures [K] + real(r8), intent(out) :: pmid_rad(ncol,nlay) ! layer midpoint pressures [Pa] + real(r8), intent(out) :: pint_rad(ncol,nlay+1) ! layer interface pressures [Pa] + real(r8), intent(out) :: t_day(nday,nlay) ! layer midpoint temperatures [K] + real(r8), intent(out) :: pmid_day(nday,nlay) ! layer midpoint pressure [Pa] + real(r8), intent(out) :: pint_day(nday,nlay+1) ! layer interface pressures [Pa] + real(r8), intent(out) :: coszrs_day(nday) ! cosine of solar zenith angle + real(r8), intent(out) :: alb_dir(nswbands,nday) ! surface albedo, direct radiation + real(r8), intent(out) :: alb_dif(nswbands,nday) ! surface albedo, diffuse radiation + ! real(r8), intent(out) :: solin(ncol) ! incident flux at domain top [W/m2] + ! real(r8), intent(out) :: solar_irrad_gpt(nday,ngpt_sw) ! incident flux at domain top per gpoint [W/m2] AT DAYLIT POINTS + ! real(r8), intent(out) :: tsi_scaling_gpt(ngpt_sw) ! scale factor for irradiance by gpoint [fraction] + real(r8), intent(out) :: tsi ! total irradiance W/m2 + + ! local variables + integer :: k, kk, i, iband + + real(r8) :: solar_band_irrad(nswbands) ! specified solar irradiance in each sw band (per radconstants) + + real(r8) :: sfac(nswbands) ! time varying scaling factors due to Solar Spectral + ! Irrad at 1 A.U. per band + real(r8) :: wavenumber_limits(2,nswbands) + + ! real(r8) :: toa_flx_by_band(nswbands) ! temporary array of incoming flux by band + ! real(r8) :: toa_flx_by_gpt(ngpt_sw) ! temporary array of incoming flux by gpt + + character(len=*), parameter :: sub='rrtmgp_set_state' + character(len=512) :: errmsg + !-------------------------------------------------------------------------------- + + ! + ! bpm note: the size of pstate%t 's 1st dimension can be larger than ncol. Assume we are only interested in 1:ncol. + ! + ! call assert_shape(pstate%t, (/ncol, pver/), errmsg) + ! if (len_trim(errmsg) > 0) then + ! write(iulog,*) '['//sub//'] : pstate%t -- shape: ',SHAPE(pstate%t),'[EXPECTED: (',ncol,'x',pver,')] max: ',maxval(pstate%t),' min: ',minval(pstate%t) + ! call endrun(sub//trim(errmsg)) + ! end if + ! call assert_shape(pstate%pmid, (/ncol, pver/), errmsg) + ! if (len_trim(errmsg) > 0) then + ! write(iulog,*) '['//sub//'] : pstate%pmid -- shape: ',SHAPE(pstate%pmid),' max: ',maxval(pstate%pmid),' min: ',minval(pstate%pmid) + ! call endrun(sub//trim(errmsg)) + ! end if + ! call assert_shape(pstate%pint, (/ncol, pverp/), errmsg) + ! if (len_trim(errmsg) > 0) then + ! write(iulog,*) '['//sub//'] : pstate%pint -- shape: ',SHAPE(pstate%pint),' max: ',maxval(pstate%pint),' min: ',minval(pstate%pint) + ! call endrun(sub//trim(errmsg)) + ! end if + + t_sfc = sqrt(sqrt(cam_in%lwup(:ncol)/stebol)) ! Surface temp set based on longwave up flux. + + ! Set surface emissivity to 1.0. + ! The land model *does* have its own surface emissivity, but is not spectrally resolved. + ! The LW upward flux is calculated with that land emissivity, and the "radiative temperature" t_sfc is derived + ! from that flux. We assume, therefore, that the emissivity is unity to be consistent with t_sfc. + emis_sfc(:,:) = 1._r8 + + + ! Assume level ordering is the same for both CAM and RAD (top to bottom) + if (nlay == pver) then + t_rad(:ncol, :) = pstate%t(:ncol, :) + pmid_rad(:ncol, :) = pstate%pmid(:ncol, :) + pint_rad(:ncol, :) = pstate%pint(:ncol, :) + else if (nlay < pver) then + t_rad(:ncol, :) = pstate%t(:ncol, pver-nlay+1:pver) + pmid_rad(:ncol, :) = pstate%pmid(:ncol, pver-nlay+1:pver) + pint_rad(:ncol, :) = pstate%pint(:ncol, pver-nlay+1:pverp) + else if (nlay > pver) then + t_rad(:ncol, nlay-pver+1:) = pstate%t(:ncol, :) + pmid_rad(:ncol, nlay-pver+1:) = pstate%pmid(:ncol, :) + pint_rad(:ncol, nlay-pver+1:) = pstate%pint(:ncol, :) + end if + + + if (nlay == pverp) then + ! add midpoint and top interface values for extra layer + t_rad(:,1) = pstate%t(:ncol,1) + pmid_rad(:,1) = 0.5_r8 * pstate%pint(:ncol,1) + + ! pint_rad(:,nlay+1) = 1.e-2_r8 ! rrtmg value (in hPa?) + pint_rad(:,1) = 1.01_r8 ! in Pa + else if (nlay > pverp) then + call endrun(sub//': ERROR: radiation should not have more layers than CAM has interfaces') + end if + + ! properties needed at day columns + do i = 1, nday + t_day(i,:) = t_rad(idxday(i),:) + pmid_day(i,:) = pmid_rad(idxday(i),:) + pint_day(i,:) = pint_rad(idxday(i),:) + coszrs_day(i) = coszrs(idxday(i)) + end do + + + ! total solar incident radiation + tsi = sol_tsi ! when using sol_tsi from solar_irrad_data, this is read from a file. + + ! TO BE REMOVED + ! We can get TSI from the solar forcing file (above). + ! We can't get the scaling here because we might not have access + ! to RRTMGP's reference irradiance on bands yet (without running kdist%gas_optics). + ! The scaling can be derived in rrtmgp_driver / rte_sw (after %gas_optics provides the toa_flux). + ! call get_ref_solar_band_irrad(solar_band_irrad) + ! call get_variability(sfac) + ! solar_band_irrad = solar_band_irrad(rrtmg_to_rrtmgp_swbands) + ! tsi = sum(solar_band_irrad(:)) ! total TSI integrated across bands, BUT NOT scaled for variability + ! ! convert from irradiance scale factor per band (sfac) to per gpoint + ! ! --> this can then be used in rrtmgp_driver module, rte_sw to scale TOA flux + ! tsi_scaling_gpt = 0.0 + + ! do iband = 1,nswbands + ! tsi_scaling_gpt(band2gpt_sw(1,iband):band2gpt_sw(2,iband)) = sfac(iband) + ! end do + + ! if we had a method to produce toa flux by gpoint, we could make that an output here. + + ! <-- begin: old way of setting albedo hard-wired to 14 SW bands --> + ! ! Surface albedo (band mapping is hardcoded for RRTMG(P) code) + ! ! This mapping assumes nswbands=14. + ! if (nswbands /= 14) & + ! call endrun(sub//': ERROR: albedo band mapping assumes nswbands=14') + + ! do i = 1, nday + ! ! Near-IR bands (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns + ! alb_dir(1:8,i) = cam_in%aldir(idxday(i)) + ! alb_dif(1:8,i) = cam_in%aldif(idxday(i)) + ! alb_dir(14,i) = cam_in%aldir(idxday(i)) + ! alb_dif(14,i) = cam_in%aldif(idxday(i)) + + ! ! Set band 24 (or, band 9 counting from 1) to use linear average of UV/visible + ! ! and near-IR values, since this band straddles 0.7 microns: + ! alb_dir(9,i) = 0.5_r8*(cam_in%aldir(idxday(i)) + cam_in%asdir(idxday(i))) + ! alb_dif(9,i) = 0.5_r8*(cam_in%aldif(idxday(i)) + cam_in%asdif(idxday(i))) + + ! ! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron + ! alb_dir(10:13,i) = cam_in%asdir(idxday(i)) + ! alb_dif(10:13,i) = cam_in%asdif(idxday(i)) + ! enddo + ! <-- end: old way of setting albedo hard-wired to 14 SW bands --> + + ! More flexible way to assign albedo (from E3SM implementation) + ! adapted here to loop over bands and cols b/c cam_in has all cols but albedos are daylit cols + ! We could remove cols loop if we just set albedos for all columns separate from rrtmgp_set_state. + ! Albedos are input as broadband (visible, and near-IR), and we need to map + ! these to appropriate bands. Bands are categorized broadly as "visible" or + ! "infrared" based on wavenumber, so we get the wavenumber limits here + wavenumber_limits = kdist_sw%get_band_lims_wavenumber() + ! Loop over bands, and determine for each band whether it is broadly in the + ! visible or infrared part of the spectrum (visible or "not visible") + do iband = 1,nswbands + if (is_visible(wavenumber_limits(1,iband)) .and. & + is_visible(wavenumber_limits(2,iband))) then + + ! Entire band is in the visible + do i = 1, nday + alb_dir(iband,i) = cam_in%asdir(idxday(i)) + alb_dif(iband,i) = cam_in%asdif(idxday(i)) + end do + + else if (.not.is_visible(wavenumber_limits(1,iband)) .and. & + .not.is_visible(wavenumber_limits(2,iband))) then + ! Entire band is in the longwave (near-infrared) + do i = 1, nday + alb_dir(iband,i) = cam_in%aldir(idxday(i)) + alb_dif(iband,i) = cam_in%aldif(idxday(i)) + end do + else + ! Band straddles the visible to near-infrared transition, so we take + ! the albedo to be the average of the visible and near-infrared + ! broadband albedos + do i = 1, nday + alb_dir(iband,i) = 0.5 * (cam_in%aldir(idxday(i)) + cam_in%asdir(idxday(i))) + alb_dif(iband,i) = 0.5 * (cam_in%aldif(idxday(i)) + cam_in%asdif(idxday(i))) + end do + end if + end do + + + ! Strictly enforce albedo bounds + where (alb_dir < 0) + alb_dir = 0.0_r8 + end where + where (alb_dir > 1) + alb_dir = 1.0_r8 + end where + where (alb_dif < 0) + alb_dif = 0.0_r8 + end where + where (alb_dif > 1) + alb_dif = 1.0_r8 + end where + +end subroutine rrtmgp_set_state +! + +! Function to check if a wavenumber is in the visible or IR +logical function is_visible(wavenumber) + + ! wavenumber in inverse cm (cm^-1) + real(r8), intent(in) :: wavenumber + + ! Threshold between visible and infrared is 0.7 micron, or 14286 cm^-1 + real(r8), parameter :: visible_wavenumber_threshold = 14286._r8 ! cm^-1 + + ! Wavenumber is in the visible if it is above the visible threshold + ! wavenumber, and in the infrared if it is below the threshold + if (wavenumber > visible_wavenumber_threshold) then + is_visible = .true. + else + is_visible = .false. + end if + +end function is_visible + + +!================================================================================================== +function get_molar_mass_ratio(gas_name) result(massratio) + ! return the molar mass ratio of dry air to gas based on gas_name + character(len=*),intent(in) :: gas_name + real(r8) :: massratio + + select case (trim(gas_name)) + case ('h2o', 'H2O') + massratio = 1.607793_r8 + case ('co2', 'CO2') + massratio = 0.658114_r8 + case ('o3', 'O3') + massratio = 0.603428_r8 + case ('ch4', 'CH4') + massratio = 1.805423_r8 + case ('n2o', 'N2O') + massratio = 0.658090_r8 + case ('o2', 'O2') + massratio = 0.905140_r8 + case ('cfc11', 'CFC11') + massratio = 0.210852_r8 + case ('cfc12', 'CFC12') + massratio = 0.239546_r8 + case default + call endrun("Invalid gas: "//trim(gas_name)) + end select +end function get_molar_mass_ratio + +subroutine rad_gas_get_vmr(icall, gas_name, pstate, pbuf, nlay, numactivecols, gas_concs, indices) + ! provides volume mixing ratio into gas_concs data structure + ! Assumes gas_name will be found with rad_cnst_get_gas(). + integer, intent(in) :: icall ! index of climate/diagnostic radiation call + character(len=*), intent(in) :: gas_name + type(physics_state), target, intent(in) :: pstate + type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: nlay ! number of layers in radiation calculation + integer, intent(in) :: numactivecols ! number of columns, ncol for LW, nday for SW + + type(ty_gas_concs), intent(inout) :: gas_concs ! the result is VRM inside gas_concs + + integer, intent(in), OPTIONAL :: indices(:) ! this would be idxday, providing the indices of the active columns + + ! local + real(r8), pointer :: gas_mmr(:,:) + real(r8), allocatable :: gas_vmr(:,:) + character(len=128) :: errmsg + real(r8), allocatable :: mmr(:,:) + character(len=*), parameter :: sub = 'rad_gas_get_vmr' + ! -- for ozone profile above model + real(r8), allocatable :: P_int(:), P_mid(:), alpha(:), beta(:), a(:), b(:), chi_mid(:), chi_0(:), chi_eff(:) + real(r8) :: P_top + integer :: idx(numactivecols) + integer :: i + real(r8) :: alpha_value + real(r8) :: amdo !! alpha_value of ozone + + + allocate(mmr(numactivecols, nlay)) + allocate(gas_vmr(numactivecols, nlay)) + + call rad_cnst_get_gas(icall, gas_name, pstate, pbuf, gas_mmr) + ! copy the gas and actually convert to mmr in case of H2O (specific to mixing ratio) + + mmr = gas_mmr + ! special case: H2O is specific humidity, not mixing ratio. Use r = q/(1-q): + if (gas_name == 'h2o') then + mmr = mmr / (1._r8 - mmr) + end if + + ! convert MMR to VMR, multipy by ratio of dry air molar mas to gas molar mass. + alpha_value = get_molar_mass_ratio(gas_name) + + ! set the column indices; when indices is provided (e.g. daylit columns) use them, otherwise just count. + do i = 1,numactivecols + if (present(indices)) then + idx(i) = indices(i) + else + idx(i) = i + end if + end do + + + if (nlay == pver) then + do i = 1,numactivecols + gas_vmr(i, :pver) = mmr(idx(i),:pver) * alpha_value + end do + else if (nlay < pver) then ! radiation calculation doesn't go through atmospheric depth + do i = 1,numactivecols + gas_vmr(i,nlay+1-pver:) = mmr(idx(i),:pver) * alpha_value + end do + else if (nlay > pver) then ! radiation has more layers than atmosphere --> only one extra layer allowed, so could say gas_vmr(:ncol, 2:) = gas_mmr(:ncol, :pver)*amdc + do i = 1,numactivecols + gas_vmr(i,nlay+1-pver:) = mmr(idx(i),:pver) * alpha_value + end do + if (nlay == pverp) then + gas_vmr(:,1) = gas_vmr(:,nlay+1-pver) + else + call endrun(sub//': Radiation can not have more than 1 extra layer.') + end if + end if + + ! special case: O3 + ! + ! """ + ! For the purpose of attenuating solar fluxes above the CAM model top, we assume that ozone + ! mixing decreases linearly in each column from the value in the top layer of CAM to zero at + ! the pressure level set by P_top. P_top has been set to 50 Pa (0.5 hPa) based on model tuning + ! to produce temperatures at the top of CAM that are most consistent with WACCM at similar pressure levels. + ! """ + if ((gas_name == 'O3') .and. (nlay == pverp)) then + allocate(P_int(numactivecols), P_mid(numactivecols), alpha(numactivecols), beta(numactivecols), a(numactivecols), b(numactivecols), chi_mid(numactivecols), chi_0(numactivecols), chi_eff(numactivecols)) + amdo = get_molar_mass_ratio('O3') + do i = 1, numactivecols + P_top = 50.0_r8 ! pressure (Pa) at which we assume O3 = 0 in linear decay from CAM top + P_int(i) = pstate%pint(idx(i),1) ! pressure (Pa) at upper interface of CAM + P_mid(i) = pstate%pmid(idx(i),1) ! pressure (Pa) at midpoint of top layer of CAM + alpha(i) = 0.0_r8 + beta(i) = 0.0_r8 + alpha(i) = log(P_int(i)/P_top) + beta(i) = log(P_mid(i)/P_int(i))/log(P_mid(i)/P_top) + + a(i) = ( (1._r8 + alpha(i)) * exp(-alpha(i)) - 1._r8 ) / alpha(i) + b(i) = 1._r8 - exp(-alpha(i)) + + if (alpha(i) .gt. 0) then ! only apply where top level is below 80 km + chi_mid(i) = mmr(i,1)*amdo ! molar mixing ratio of O3 at midpoint of top layer + chi_0(i) = chi_mid(i) / (1._r8 + beta(i)) + chi_eff(i) = chi_0(i) * (a(i) + b(i)) + gas_vmr(i,1) = chi_eff(i) + chi_eff(i) = chi_eff(i) * P_int(i) / amdo / 9.8_r8 ! O3 column above in kg m-2 + chi_eff(i) = chi_eff(i) / 2.1415e-5_r8 ! O3 column above in DU + end if + end do + deallocate(P_int, P_mid, alpha, beta, a, b, chi_mid, chi_0, chi_eff) + end if + + ! other special cases: + ! N2 and CO: If these are in the gas list, would set them to constants + ! as in E3SM. Currently, these will abort run because they are not found by rad_cnst_get_gas. + ! So while RTE-RRTMGP can cope with them, we do not use them for radiation at this time. + + errmsg = gas_concs%set_vmr(gas_name, gas_vmr) + if (len_trim(errmsg) > 0) then + call endrun(sub//': error setting CO2: '//trim(errmsg)) + end if + + deallocate(gas_vmr) + deallocate(mmr) + +end subroutine rad_gas_get_vmr + +!================================================================================================== + +subroutine rrtmgp_set_gases_lw(icall, pstate, pbuf, nlay, gas_concs) + + ! The gases in the LW coefficients file are: + ! H2O, CO2, O3, N2O, CO, CH4, O2, N2 + ! But we only use the gases in the radconstants module's gaslist. + + ! The memory management for the gas_concs object is internal. The arrays passed to it + ! are copied to the internally allocated memory. Each call to the set_vmr method checks + ! whether the gas already has memory allocated, and if it does that memory is deallocated + ! and new memory is allocated. + + ! arguments + integer, intent(in) :: icall ! index of climate/diagnostic radiation call + type(physics_state), target, intent(in) :: pstate + type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: nlay + type(ty_gas_concs), intent(inout) :: gas_concs + + ! local variables + integer :: ncol + + integer :: lchnk + character(len=*), parameter :: sub = 'rrtmgp_set_gases_lw' + integer :: i + !-------------------------------------------------------------------------------- + + ncol = pstate%ncol + lchnk = pstate%lchnk + do i = 1,nradgas + call rad_gas_get_vmr(icall, gaslist(i), pstate, pbuf, nlay, ncol, gas_concs) + end do +end subroutine rrtmgp_set_gases_lw + +!================================================================================================== + +subroutine rrtmgp_set_gases_sw( & + icall, pstate, pbuf, nlay, nday, & + idxday, gas_concs) + + ! Return gas_concs with gas volume mixing ratio on DAYLIT columns. + + ! The gases in the SW coefficients file are: + ! H2O, CO2, O3, N2O, CO, CH4, O2, N2, CCL4, CFC11, CFC12, CFC22, HFC143a, + ! HFC125, HFC23, HFC32, HFC134a, CF4, NO2 + ! We only use the gases in radconstants gaslist. + + ! arguments + integer, intent(in) :: icall ! index of climate/diagnostic radiation call + type(physics_state), target, intent(in) :: pstate + type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: nlay + integer, intent(in) :: nday + integer, intent(in) :: idxday(:) + type(ty_gas_concs), intent(inout) :: gas_concs + + ! local variables + character(len=*), parameter :: sub = 'rrtmgp_set_gases_sw' + integer :: i + + ! use the optional argument indices to specify which columns are sunlit + do i = 1,nradgas + call rad_gas_get_vmr(icall, gaslist(i), pstate, pbuf, nlay, nday, gas_concs, indices=idxday) + end do + +end subroutine rrtmgp_set_gases_sw + +!================================================================================================== + +subroutine rrtmgp_set_cloud_lw(state, nlwbands, cldfrac, c_cld_lw_abs, lwkDist, cloud_lw) + + ! Create MCICA stochastic arrays for cloud LW optical properties. + + ! arguments + type(physics_state), intent(in) :: state + integer, intent(in) :: nlwbands + real(r8), intent(in) :: cldfrac(pcols,pver) ! combined cloud fraction (snow plus regular) + real(r8), intent(in) :: c_cld_lw_abs(nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) + class(ty_gas_optics_rrtmgp), intent(in) :: lwkDist + type(ty_optical_props_1scl), intent(inout) :: cloud_lw + ! local vars + integer :: i + integer :: ncol + integer :: ngptlw + real(r8), allocatable :: taucmcl(:,:,:) ! cloud optical depth [mcica] + character(len=32) :: sub = 'rrtmgp_set_cloud_lw' + character(len=128) :: errmsg + !-------------------------------------------------------------------------------- + ncol = state%ncol + ngptlw = lwkDist%get_ngpt() + + allocate(taucmcl(ngptlw,ncol,pver)) + + !***NB*** this code is currently set up to create the subcols for all model layers + ! not just the ones where the radiation calc is being done. Need + ! to subset cldfrac and c_cld_lw_abs to avoid computing unneeded random numbers. + + call mcica_subcol_lw( & + lwkdist, & ! spectral information + nlwbands, & ! number of spectral bands + ngptlw, & ! number of subcolumns (g-point intervals) + ncol, & ! number of columns + ngptlw, & ! changeseed, should be set to number of subcolumns + state%pmid, & ! layer pressures (Pa) + cldfrac, & ! layer cloud fraction + c_cld_lw_abs, & ! cloud optical depth + taucmcl & ! OUTPUT: subcolumn cloud optical depth [mcica] (ngpt, ncol, nver) + ) + + ! If there is an extra layer in the radiation then this initialization + ! will provide zero optical depths there. + cloud_lw%tau = 0.0_r8 + do i = 1, ngptlw + cloud_lw%tau(:ncol, ktopradm:, i) = taucmcl(i, :ncol, ktopcamm:) + end do + errmsg = cloud_lw%validate() + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: cloud_lw%validate: '//trim(errmsg)) + end if + deallocate(taucmcl) +end subroutine rrtmgp_set_cloud_lw + +!================================================================================================== + +subroutine rrtmgp_set_aer_lw(ncol, nlwbands, aer_lw_abs, aer_lw) + + ! Load aerosol optical properties into the RRTMGP object. + + ! arguments + integer, intent(in) :: ncol + integer, intent(in) :: nlwbands + real(r8), intent(in) :: aer_lw_abs(pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + type(ty_optical_props_1scl), intent(inout) :: aer_lw + character(len=32) :: sub = 'rrtmgp_set_aer_lw' + character(len=128) :: errmsg + + !-------------------------------------------------------------------------------- + ! If there is an extra layer in the radiation then this initialization + ! will provide zero optical depths there. + aer_lw%tau = 0.0_r8 + aer_lw%tau(:ncol, ktopradm:, :) = aer_lw_abs(:ncol, ktopcamm:, :) + errmsg = aer_lw%validate() + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: aer_lw%validate: '//trim(errmsg)) + end if +end subroutine rrtmgp_set_aer_lw + +!================================================================================================== + +subroutine rrtmgp_set_cloud_sw( & + nswbands, nday, nlay, idxday, pmid, cldfrac, & + c_cld_tau, c_cld_tau_w, c_cld_tau_w_g, c_cld_tau_w_f, kdist_sw, & + cloud_sw) + + ! Create MCICA stochastic arrays for cloud SW optical properties. + + ! arguments + integer, intent(in) :: nswbands + integer, intent(in) :: nday + integer, intent(in) :: nlay ! number of layers in rad calc (may include "extra layer") + integer, intent(in) :: idxday(:) + + real(r8), intent(in) :: pmid(nday,nlay) ! pressure at layer midpoints (Pa) + real(r8), intent(in) :: cldfrac(pcols,pver) ! combined cloud fraction (snow plus regular) + real(r8), intent(in) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth + real(r8), intent(in) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau + real(r8), intent(in) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau + real(r8), intent(in) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau + + class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! shortwave gas optics object + type(ty_optical_props_2str), intent(inout) :: cloud_sw ! cloud optical properties object + + ! local vars + integer, parameter :: changeseed = 1 + + integer :: i, k, kk, ns, igpt + integer :: ngptsw + integer :: nver ! nver is the number of cam layers in the SW calc. It + ! does not include the "extra layer". + + real(r8), allocatable :: cldf(:,:) + real(r8), allocatable :: tauc(:,:,:) + real(r8), allocatable :: ssac(:,:,:) + real(r8), allocatable :: asmc(:,:,:) + real(r8), allocatable :: taucmcl(:,:,:) + real(r8), allocatable :: ssacmcl(:,:,:) + real(r8), allocatable :: asmcmcl(:,:,:) + + character(len=32) :: sub = 'rrtmgp_set_cloud_sw' + character(len=128) :: errmsg + real(r8) :: small_val = 1.e-80_r8 + real(r8), allocatable :: day_cld_tau(:,:,:) + real(r8), allocatable :: day_cld_tau_w(:,:,:) + real(r8), allocatable :: day_cld_tau_w_g(:,:,:) + !-------------------------------------------------------------------------------- + ngptsw = kdist_sw%get_ngpt() + nver = pver - ktopcamm + 1 ! number of CAM's layers in radiation calculation. + + ! Compute the input quantities needed for the 2-stream optical props + ! object. Also subset the vertical levels and the daylight columns + ! here. But don't reorder the vertical index because the mcica sub-column + ! generator assumes the CAM vertical indexing. + allocate( & + cldf(nday,nver), & + tauc(nswbands,nday,nver), & + ssac(nswbands,nday,nver), & + asmc(nswbands,nday,nver), & + taucmcl(ngptsw,nday,nver), & + ssacmcl(ngptsw,nday,nver), & + asmcmcl(ngptsw,nday,nver), & + day_cld_tau(nswbands,nday,nver), & + day_cld_tau_w(nswbands,nday,nver), & + day_cld_tau_w_g(nswbands,nday,nver)) + + ! get daylit arrays on radiation levels, note: expect idxday to be truncated to size nday + day_cld_tau = c_cld_tau( :, idxday(1:nday), ktopcamm:) + day_cld_tau_w = c_cld_tau_w( :, idxday(1:nday), ktopcamm:) + day_cld_tau_w_g = c_cld_tau_w_g(:, idxday(1:nday), ktopcamm:) + cldf = cldfrac(idxday(1:nday), ktopcamm:) ! daylit cloud fraction on radiation levels + tauc = merge(day_cld_tau, 0.0_r8, day_cld_tau > 0.0_r8) ! start by setting cloud optical depth, clip @ zero + asmc = merge(day_cld_tau_w_g / max(day_cld_tau_w, small_val), 0.0_r8, day_cld_tau_w > 0.0_r8) ! set value of asymmetry + ssac = merge(max(day_cld_tau_w, small_val) / max(tauc, small_val), 1.0_r8 , tauc > 0.0_r8) + asmc = merge(asmc, 0.0_r8, tauc > 0.0_r8) ! double-check asymmetry; reset when tauc = 0 + + + ! mcica_subcol_sw converts to gpts (e.g., 224 pts instead of 14 bands) + ! inputs (pmid, cldf, tauc, ssac, asmc) and outputs (taucmcl, ssacmcl, asmcmcl) + ! are on the same nver vertical levels + ! output is shape (ngpt, ncol, nver) + call mcica_subcol_sw( & + kdist_sw, nswbands, ngptsw, nday, nlay, nver, changeseed, & + pmid, cldf, tauc, ssac, asmc, & + taucmcl, ssacmcl, asmcmcl) ! 32 + + + ! If there is an extra layer in the radiation then this initialization + ! will provide the optical properties there. + ! These should be shape (ncol, nlay, ngpt); assign levels using ktopradm+k, should + cloud_sw%tau(:,:,:) = 0.0_r8 + cloud_sw%ssa(:,:,:) = 1.0_r8 + cloud_sw%g(:,:,:) = 0.0_r8 + do igpt = 1,ngptsw + cloud_sw%g (:, ktopradm:, igpt) = asmcmcl(igpt, ktopcamm:, :) + cloud_sw%ssa(:, ktopradm:, igpt) = ssacmcl(igpt, ktopcamm:, :) + cloud_sw%tau(:, ktopradm:, igpt) = taucmcl(igpt, ktopcamm:, :) + end do + + + errmsg = cloud_sw%validate() + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: cloud_sw%validate: '//trim(errmsg)) + end if + + ! delta scaling adjusts for forward scattering + ! If delta_scale() is applied, cloud_sw%tau differs from RRTMG implementation going into SW calculation. + errmsg = cloud_sw%delta_scale() + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: cloud_sw%delta_scale: '//trim(errmsg)) + end if + + ! all information is in cloud_sw, now deallocate + deallocate( & + cldf, tauc, ssac, asmc, & + taucmcl, ssacmcl, asmcmcl,& + day_cld_tau, day_cld_tau_w, day_cld_tau_w_g ) + +end subroutine rrtmgp_set_cloud_sw + +!================================================================================================== + +subroutine rrtmgp_set_aer_sw( & + nswbands, nday, idxday, aer_tau, aer_tau_w, & + aer_tau_w_g, aer_tau_w_f, aer_sw) + + ! Load aerosol SW optical properties into the RRTMGP object. + ! + ! *** N.B. *** The input optical arrays from CAM are dimensioned in the vertical + ! as 0:pver. The index 0 is for the extra layer used in the radiation + ! calculation. + + + ! arguments + integer, intent(in) :: nswbands + integer, intent(in) :: nday + integer, intent(in) :: idxday(:) + real(r8), intent(in) :: aer_tau (pcols,0:pver,nswbands) ! extinction optical depth + real(r8), intent(in) :: aer_tau_w (pcols,0:pver,nswbands) ! single scattering albedo * tau + real(r8), intent(in) :: aer_tau_w_g(pcols,0:pver,nswbands) ! asymmetry parameter * w * tau + real(r8), intent(in) :: aer_tau_w_f(pcols,0:pver,nswbands) ! forward scattered fraction * w * tau + type(ty_optical_props_2str), intent(inout) :: aer_sw + + ! local variables + integer :: ns + integer :: k, kk + integer :: i + integer, dimension(nday) :: day_cols + character(len=32) :: sub = 'rrtmgp_set_aer_sw' + character(len=128) :: errmsg + !-------------------------------------------------------------------------------- + ! If there is an extra layer in the radiation then this initialization + ! will provide default values there. + aer_sw%tau = 0.0_r8 + aer_sw%ssa = 1.0_r8 + aer_sw%g = 0.0_r8 + day_cols = idxday(1:nday) + + ! aer_sw is on RAD grid, aer_tau* is on CAM grid ... to make sure they align, use ktop* + ! aer_sw has dimensions of (nday, nlay, nswbands) + aer_sw%tau(1:nday, ktopradm:, :) = max(aer_tau(day_cols, ktopcamm:, :), 0._r8) + aer_sw%ssa(1:nday, ktopradm:, :) = merge(aer_tau_w(day_cols, ktopcamm:,:)/aer_tau(day_cols, ktopcamm:, :), 1._r8, aer_tau(day_cols, ktopcamm:, :) > 0._r8) + aer_sw%g( 1:nday, ktopradm:, :) = merge(aer_tau_w_g(day_cols, ktopcamm:, :) / aer_tau_w(day_cols, ktopcamm:, :), 0._r8, aer_tau_w(day_cols, ktopcamm:, :) > 1.e-80_r8) + + ! impose limits on the components: + ! aer_sw%tau = max(aer_sw%tau, 0._r) <-- already imposed + aer_sw%ssa = min(max(aer_sw%ssa, 0._r8), 1._r8) + aer_sw%g = min(max(aer_sw%g, -1._r8), 1._r8) + ! by clamping the values here, the validate method should be guaranteed to succeed, + ! but we're also saying that any errors in the method to this point are being swept aside. + ! We might want to check for out-of-bounds values and report them in the log file. + + errmsg = aer_sw%validate() + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: aer_sw%validate: '//trim(errmsg)) + end if +end subroutine rrtmgp_set_aer_sw + +!================================================================================================== + +subroutine expand_and_transpose(ops,arr_in,arr_out) + ! based on version in mo_rte_sw + class(ty_gas_optics_rrtmgp), intent(in) :: ops ! spectral information + real(r8), dimension(:), intent(in ) :: arr_in ! (nband) + real(r8), dimension(:), intent(out) :: arr_out ! (igpt) + ! ------------- + integer :: nband, ngpt + integer :: iband, igpt + integer, dimension(2,ops%get_nband()) :: limits + + nband = ops%get_nband() + ngpt = ops%get_ngpt() + limits = ops%get_band_lims_gpoint() + do iband = 1, nband + do igpt = limits(1, iband), limits(2, iband) + arr_out(igpt) = arr_in(iband) + end do + end do + + end subroutine expand_and_transpose + +end module rrtmgp_inputs diff --git a/src/physics/rrtmgp/slingo.F90 b/src/physics/rrtmgp/slingo.F90 new file mode 100644 index 0000000000..aedb44bcee --- /dev/null +++ b/src/physics/rrtmgp/slingo.F90 @@ -0,0 +1,409 @@ +module slingo + +!------------------------------------------------------------------------------------------------ +! Implements Slingo Optics for MG/RRTMG for liquid clouds and +! a copy of the old cloud routine for reference +!------------------------------------------------------------------------------------------------ + +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only: pcols, pver, pverp +use physics_types, only: physics_state +use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx +use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag, get_sw_spectral_boundaries +use cam_abortutils, only: endrun +use cam_history, only: outfld + +implicit none +private +save + +public :: & + slingo_rad_props_init, & + cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols + cloud_rad_props_get_lw, & ! return LW optical props of total bulk aerosols + slingo_liq_get_rad_props_lw, & + slingo_liq_optics_sw + +! Minimum cloud amount (as a fraction of the grid-box area) to +! distinguish from clear sky +! + real(r8) cldmin + parameter (cldmin = 1.0e-80_r8) +! +! Decimal precision of cloud amount (0 -> preserve full resolution; +! 10^-n -> preserve n digits of cloud amount) +! + real(r8) cldeps + parameter (cldeps = 0.0_r8) + +! +! indexes into pbuf for optical parameters of MG clouds +! + integer :: iclwp_idx = 0 + integer :: iciwp_idx = 0 + integer :: cld_idx = 0 + integer :: rel_idx = 0 + integer :: rei_idx = 0 + +! indexes into constituents for old optics + integer :: & + ixcldliq, & ! cloud liquid water index + ixcldice ! cloud liquid water index + + +!============================================================================== +contains +!============================================================================== + +subroutine slingo_rad_props_init() + +! use cam_history, only: addfld + use netcdf + use spmd_utils, only: masterproc + use ioFileMod, only: getfil + use cam_logfile, only: iulog + use error_messages, only: handle_ncerr +#if ( defined SPMD ) + use mpishorthand +#endif + use constituents, only: cnst_get_ind + + integer :: err + + iciwp_idx = pbuf_get_index('ICIWP',errcode=err) + iclwp_idx = pbuf_get_index('ICLWP',errcode=err) + cld_idx = pbuf_get_index('CLD') + rel_idx = pbuf_get_index('REL') + rei_idx = pbuf_get_index('REI') + + ! old optics + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + + !call addfld ('CLWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','old In Cloud Liquid Water Path', sampling_seq='rad_lwsw') + !call addfld ('KEXT_OLD',(/ 'lev' /),'I','m^2/kg','old extinction') + !call addfld ('CLDOD_OLD',(/ 'lev' /),'I','1','old liquid OD') + !call addfld ('REL_OLD',(/ 'lev' /),'I','1','old liquid effective radius (liquid)') + + !call addfld ('CLWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Liquid Water Path', sampling_seq='rad_lwsw') + !call addfld ('KEXT_NEW',(/ 'lev' /),'I','m^2/kg','extinction') + !call addfld ('CLDOD_NEW',(/ 'lev' /),'I','1','liquid OD') + + !call addfld('CIWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path', sampling_seq='rad_lwsw') + !call addfld('CIWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path (old)', sampling_seq='rad_lwsw') + + return + +end subroutine slingo_rad_props_init + +!============================================================================== + +subroutine cloud_rad_props_get_sw(state, pbuf, & + tau, tau_w, tau_w_g, tau_w_f,& + diagnosticindex) + +! return totaled (across all species) layer tau, omega, g, f +! for all spectral interval for aerosols affecting the climate + + ! Arguments + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + integer, optional, intent(in) :: diagnosticindex ! index (if present) to radiation diagnostic information + + real(r8), intent(out) :: tau (nswbands,pcols,pver) ! aerosol extinction optical depth + real(r8), intent(out) :: tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau + real(r8), intent(out) :: tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w + real(r8), intent(out) :: tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w + + ! Local variables + + integer :: ncol + integer :: lchnk + integer :: k, i ! lev and daycolumn indices + integer :: iswband ! sw band indices + + real(r8) :: liq_tau (nswbands,pcols,pver) ! aerosol extinction optical depth + real(r8) :: liq_tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau + real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w + real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w + + + !----------------------------------------------------------------------------- + + ncol = state%ncol + lchnk = state%lchnk + + call slingo_liq_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f, oldliqwp=.true. ) + +end subroutine cloud_rad_props_get_sw +!============================================================================== + +subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldliq, oldice, oldcloud) + +! Purpose: Compute cloud longwave absorption optical depth +! cloud_rad_props_get_lw() is called by radlw() + + ! Arguments + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer + integer, optional, intent(in) :: diagnosticindex + logical, optional, intent(in) :: oldliq ! use old liquid optics + logical, optional, intent(in) :: oldice ! use old ice optics + logical, optional, intent(in) :: oldcloud ! use old optics for both (b4b) + + ! Local variables + + integer :: bnd_idx ! LW band index + integer :: i ! column index + integer :: k ! lev index + integer :: ncol ! number of columns + integer :: lchnk + + ! rad properties for liquid clouds + real(r8) :: liq_tau_abs_od(nlwbands,pcols,pver) ! liquid cloud absorption optical depth + + !----------------------------------------------------------------------------- + + ncol = state%ncol + lchnk = state%lchnk + + ! compute optical depths cld_absod + cld_abs_od = 0._r8 + + call slingo_liq_get_rad_props_lw(state, pbuf, liq_tau_abs_od, oldliqwp=.true.) + + cld_abs_od(:,1:ncol,:) = liq_tau_abs_od(:,1:ncol,:) + +end subroutine cloud_rad_props_get_lw + +!============================================================================== +! Private methods +!============================================================================== + + +subroutine slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp) + + use physconst, only: gravit + + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + logical, intent(in) :: oldliqwp + + real(r8), pointer, dimension(:,:) :: rel + real(r8), pointer, dimension(:,:) :: cldn + real(r8), pointer, dimension(:,:) :: tmpptr + real(r8), dimension(pcols,pver) :: cliqwp + real(r8), dimension(nswbands) :: wavmin + real(r8), dimension(nswbands) :: wavmax + + ! Minimum cloud amount (as a fraction of the grid-box area) to + ! distinguish from clear sky + real(r8), parameter :: cldmin = 1.0e-80_r8 + + ! Decimal precision of cloud amount (0 -> preserve full resolution; + ! 10^-n -> preserve n digits of cloud amount) + real(r8), parameter :: cldeps = 0.0_r8 + + ! A. Slingo's data for cloud particle radiative properties (from 'A GCM + ! Parameterization for the Shortwave Properties of Water Clouds' JAS + ! vol. 46 may 1989 pp 1419-1427) + real(r8) :: abarl(4) = & ! A coefficient for extinction optical depth + (/ 2.817e-02_r8, 2.682e-02_r8,2.264e-02_r8,1.281e-02_r8/) + real(r8) :: bbarl(4) = & ! B coefficient for extinction optical depth + (/ 1.305_r8 , 1.346_r8 ,1.454_r8 ,1.641_r8 /) + real(r8) :: cbarl(4) = & ! C coefficient for single scat albedo + (/-5.62e-08_r8 ,-6.94e-06_r8 ,4.64e-04_r8 ,0.201_r8 /) + real(r8) :: dbarl(4) = & ! D coefficient for single scat albedo + (/ 1.63e-07_r8 , 2.35e-05_r8 ,1.24e-03_r8 ,7.56e-03_r8 /) + real(r8) :: ebarl(4) = & ! E coefficient for asymmetry parameter + (/ 0.829_r8 , 0.794_r8 ,0.754_r8 ,0.826_r8 /) + real(r8) :: fbarl(4) = & ! F coefficient for asymmetry parameter + (/ 2.482e-03_r8, 4.226e-03_r8,6.560e-03_r8,4.353e-03_r8/) + + real(r8) :: abarli ! A coefficient for current spectral band + real(r8) :: bbarli ! B coefficient for current spectral band + real(r8) :: cbarli ! C coefficient for current spectral band + real(r8) :: dbarli ! D coefficient for current spectral band + real(r8) :: ebarli ! E coefficient for current spectral band + real(r8) :: fbarli ! F coefficient for current spectral band + + ! Caution... A. Slingo recommends no less than 4.0 micro-meters nor + ! greater than 20 micro-meters + + integer :: ns, i, k, indxsl, Nday + integer :: i_rel, lchnk, icld, itim_old + real(r8) :: tmp1l, tmp2l, tmp3l, g + real(r8) :: kext(pcols,pver) + real(r8), pointer, dimension(:,:) :: iclwpth + + Nday = state%ncol + lchnk = state%lchnk + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, rel_idx, rel) + + if (oldliqwp) then + do k=1,pver + do i = 1,Nday + cliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/(gravit*max(0.01_r8,cldn(i,k))) + end do + end do + else + if (iclwp_idx<=0) then + call endrun('slingo_liq_optics_sw: oldliqwp must be set to true since ICLWP was not found in pbuf') + endif + ! The following is the eventual target specification for in cloud liquid water path. + call pbuf_get_field(pbuf, iclwp_idx, tmpptr) + cliqwp = tmpptr + endif + + call get_sw_spectral_boundaries(wavmin,wavmax,'microns') + + do ns = 1, nswbands + ! Set index for cloud particle properties based on the wavelength, + ! according to A. Slingo (1989) equations 1-3: + ! Use index 1 (0.25 to 0.69 micrometers) for visible + ! Use index 2 (0.69 - 1.19 micrometers) for near-infrared + ! Use index 3 (1.19 to 2.38 micrometers) for near-infrared + ! Use index 4 (2.38 to 4.00 micrometers) for near-infrared + if(wavmax(ns) <= 0.7_r8) then + indxsl = 1 + else if(wavmax(ns) <= 1.25_r8) then + indxsl = 2 + else if(wavmax(ns) <= 2.38_r8) then + indxsl = 3 + else if(wavmax(ns) > 2.38_r8) then + indxsl = 4 + end if + + ! Set cloud extinction optical depth, single scatter albedo, + ! asymmetry parameter, and forward scattered fraction: + abarli = abarl(indxsl) + bbarli = bbarl(indxsl) + cbarli = cbarl(indxsl) + dbarli = dbarl(indxsl) + ebarli = ebarl(indxsl) + fbarli = fbarl(indxsl) + + do k=1,pver + do i=1,Nday + + ! note that optical properties for liquid valid only + ! in range of 4.2 > rel > 16 micron (Slingo 89) + if (cldn(i,k) >= cldmin .and. cldn(i,k) >= cldeps) then + tmp1l = abarli + bbarli/min(max(4.2_r8,rel(i,k)),16._r8) + liq_tau(ns,i,k) = 1000._r8*cliqwp(i,k)*tmp1l + else + liq_tau(ns,i,k) = 0.0_r8 + endif + + tmp2l = 1._r8 - cbarli - dbarli*min(max(4.2_r8,rel(i,k)),16._r8) + tmp3l = fbarli*min(max(4.2_r8,rel(i,k)),16._r8) + ! Do not let single scatter albedo be 1. Delta-eddington solution + ! for non-conservative case has different analytic form from solution + ! for conservative case, and raddedmx is written for non-conservative case. + liq_tau_w(ns,i,k) = liq_tau(ns,i,k) * min(tmp2l,.999999_r8) + g = ebarli + tmp3l + liq_tau_w_g(ns,i,k) = liq_tau_w(ns,i,k) * g + liq_tau_w_f(ns,i,k) = liq_tau_w(ns,i,k) * g * g + + end do ! End do i=1,Nday + end do ! End do k=1,pver + end do ! nswbands + + !call outfld('CL_OD_SW_OLD',liq_tau(idx_sw_diag,:,:), pcols, lchnk) + !call outfld('REL_OLD',rel(:,:), pcols, lchnk) + !call outfld('CLWPTH_OLD',cliqwp(:,:), pcols, lchnk) + !call outfld('KEXT_OLD',kext(:,:), pcols, lchnk) + + +end subroutine slingo_liq_optics_sw + +subroutine slingo_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp) + use physconst, only: gravit + + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) + logical, intent(in) :: oldliqwp + + real(r8) :: gicewp(pcols,pver) + real(r8) :: gliqwp(pcols,pver) + real(r8) :: cicewp(pcols,pver) + real(r8) :: cliqwp(pcols,pver) + real(r8) :: ficemr(pcols,pver) + real(r8) :: cwp(pcols,pver) + real(r8) :: cldtau(pcols,pver) + + real(r8), pointer, dimension(:,:) :: cldn + real(r8), pointer, dimension(:,:) :: rei + integer :: ncol, icld, itim_old, i_rei, 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), pointer, dimension(:,:) :: iclwpth, iciwpth + + ncol=state%ncol + lchnk = state%lchnk + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, rei_idx, rei) + call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + if (oldliqwp) then + do k=1,pver + do i = 1,ncol + gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path. + gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path. + cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. + cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. + ficemr(i,k) = state%q(i,k,ixcldice) / & + max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq))) + end do + end do + cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) + else + if (iclwp_idx<=0 .or. iciwp_idx<=0) then + call endrun('slingo_liq_get_rad_props_lw: oldliqwp must be set to true since ICIWP and/or ICLWP were not found in pbuf') + endif + call pbuf_get_field(pbuf, iclwp_idx, iclwpth) + call pbuf_get_field(pbuf, iciwp_idx, iciwpth) + do k=1,pver + do i = 1,ncol + cwp (i,k) = 1000.0_r8 * iclwpth(i,k) + 1000.0_r8 * iciwpth(i, k) + ficemr(i,k) = 1000.0_r8 * iciwpth(i,k)/(max(1.e-18_r8, cwp(i,k))) + end do + end do + endif + + + do k=1,pver + do i=1,ncol + + ! Note from Andrew Conley: + ! Optics for RK no longer supported, This is constructed to get + ! close to bit for bit. Otherwise we could simply use liquid water path + !note that optical properties for ice valid only + !in range of 13 > rei > 130 micron (Ebert and Curry 92) + kabs = kabsl*(1._r8-ficemr(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 + + +end subroutine slingo_liq_get_rad_props_lw + +end module slingo From c17e5e6b175fa4e1dc092900a38e0ff390a4949b Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 11 May 2023 15:52:56 -0400 Subject: [PATCH 02/53] update .gitignore with rrtmgp external --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 08b47940f0..0002f00ca1 100644 --- a/.gitignore +++ b/.gitignore @@ -11,6 +11,7 @@ src/physics/cosp2/src src/physics/silhs src/physics/pumas src/physics/pumas-frozen +src/physics/rrtmgp/ext src/dynamics/fv3/atmos_cubed_sphere libraries/FMS libraries/mct From e761a7401b095f54379522116788ff4e7b84fb7f Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 16 May 2023 12:29:53 -0400 Subject: [PATCH 03/53] get rrtmgp from my fork --- Externals_CAM.cfg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index a87d3b1719..05d7b1ada3 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -1,8 +1,8 @@ [rrtmgp] local_path = src/physics/rrtmgp/ext protocol = git -repo_url = https://github.com/earth-system-radiation/rte-rrtmgp.git -tag = v1.6 +repo_url = https://github.com/brian-eaton/rte-rrtmgp.git +tag = build_mod01 required = True [chem_proc] From 430185cf7050adb791d59e513010f0a5fcca834c Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 16 May 2023 21:31:01 -0400 Subject: [PATCH 04/53] comment out non-working memory monitoring code --- src/physics/rrtmgp/radiation.F90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index c33a36101b..e3a631d4c4 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1538,7 +1538,7 @@ subroutine radiation_tend( & ! call endrun(sub//': ERROR code returned by check_bounds gas_concs_sw: '//trim(errmsg)) ! end if ! call check_bounds(kdist_sw, errmsg) - call shr_mem_getusage(mem_hw_beg, mem_beg) +! call shr_mem_getusage(mem_hw_beg, mem_beg) ! inputs are the daylit columns --> output fluxes therefore also on daylit columns. errmsg = rte_sw( kdist_sw, & ! input (from init) gas_concs_sw, & ! input, (from rrtmgp_set_gases_sw) @@ -1555,17 +1555,17 @@ subroutine radiation_tend( & tsi_scaling=eccf & !< optional input, scaling for irradiance ) - call shr_mem_getusage(mem_hw_end, mem_end) - temp = mem_hw_end - mem_hw_beg - if (masterproc) then - write(iulog, *) 'rte_sw: Increase in memory highwater = ', & - temp, ' (MB)' - end if - temp = mem_end - mem_beg - if (masterproc) then - write(iulog, *) 'rte_sw: Increase in memory usage = ', & - temp, ' (MB)' - end if +! call shr_mem_getusage(mem_hw_end, mem_end) +! temp = mem_hw_end - mem_hw_beg +! if (masterproc) then +! write(iulog, *) 'rte_sw: Increase in memory highwater = ', & +! temp, ' (MB)' +! end if +! temp = mem_end - mem_beg +! if (masterproc) then +! write(iulog, *) 'rte_sw: Increase in memory usage = ', & +! temp, ' (MB)' +! end if if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR code returned by rte_sw: '//trim(errmsg)) From 7acbb785ec6a2175d75935d354ac2f9594c40b8a Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 5 Jul 2023 10:12:06 -0400 Subject: [PATCH 05/53] use parameters for nswbands, nlwbands --- src/physics/cam/modal_aer_opt.F90 | 16 +-- src/physics/rrtmgp/b_checker.f90 | 163 --------------------------- src/physics/rrtmgp/rad_solar_var.F90 | 21 ++-- src/physics/rrtmgp/radconstants.F90 | 60 ++-------- src/physics/rrtmgp/radiation.F90 | 83 +++----------- 5 files changed, 38 insertions(+), 305 deletions(-) delete mode 100644 src/physics/rrtmgp/b_checker.f90 diff --git a/src/physics/cam/modal_aer_opt.F90 b/src/physics/cam/modal_aer_opt.F90 index 160e47e86c..5c95c17840 100644 --- a/src/physics/cam/modal_aer_opt.F90 +++ b/src/physics/cam/modal_aer_opt.F90 @@ -53,8 +53,8 @@ module modal_aer_opt real(r8) :: xrmin, xrmax ! refractive index for water read in read_water_refindex -complex(r8), allocatable :: crefwsw(:) ! complex refractive index for water visible -complex(r8), allocatable :: crefwlw(:) ! complex refractive index for water infrared +complex(r8) :: crefwsw(nswbands) ! complex refractive index for water visible +complex(r8) :: crefwlw(nlwbands) ! complex refractive index for water infrared ! physics buffer indices integer :: dgnumwet_idx = -1 @@ -601,7 +601,7 @@ subroutine modal_aero_sw(list_idx, state, pbuf, nnite, idxnite, & lchnk = state%lchnk ncol = state%ncol - if (.not. allocated(crefwsw)) allocate(crefwsw(nswbands)) + ! initialize output variables tauxar(:ncol,:,:) = 0._r8 wa(:ncol,:,:) = 0._r8 @@ -1062,7 +1062,6 @@ subroutine modal_aero_sw(list_idx, state, pbuf, nnite, idxnite, & deallocate(drymass_m) deallocate(so4dryvol_m) deallocate(naer_m) - deallocate(crefwsw) end if ! Output visible band diagnostics for quantities summed over the modes @@ -1257,7 +1256,7 @@ subroutine modal_aero_lw(list_idx, state, pbuf, tauxar) lchnk = state%lchnk ncol = state%ncol - if (.not. allocated(crefwlw)) allocate(crefwlw(nlwbands)) + ! initialize output variables tauxar(:ncol,:,:) = 0._r8 @@ -1439,7 +1438,6 @@ subroutine modal_aero_lw(list_idx, state, pbuf, tauxar) deallocate(drymass_m) deallocate(so4dryvol_m) deallocate(naer_m) - deallocate(crefwlw) end if end subroutine modal_aero_lw @@ -1464,8 +1462,7 @@ subroutine read_water_refindex(infilename) real(r8) :: refrwsw(nswbands), refiwsw(nswbands) ! real, imaginary ref index for water visible real(r8) :: refrwlw(nlwbands), refiwlw(nlwbands) ! real, imaginary ref index for water infrared !---------------------------------------------------------------------------- - if (.not. allocated(crefwsw)) allocate(crefwsw(nswbands)) - if (.not. allocated(crefwlw)) allocate(crefwlw(nlwbands)) + ! open file call cam_pio_openfile(ncid, infilename, PIO_NOWRITE) @@ -1507,8 +1504,7 @@ subroutine read_water_refindex(infilename) end do call pio_closefile(ncid) - deallocate(crefwsw) - deallocate(crefwlw) + end subroutine read_water_refindex !=============================================================================== diff --git a/src/physics/rrtmgp/b_checker.f90 b/src/physics/rrtmgp/b_checker.f90 deleted file mode 100644 index a24d7c7b5e..0000000000 --- a/src/physics/rrtmgp/b_checker.f90 +++ /dev/null @@ -1,163 +0,0 @@ -module b_checker -!--------------------------------------------------------------------------------- -! -! Instrumentation for debugging CAM interface to RRTMGP radiation parameterization. -! -!--------------------------------------------------------------------------------- - use shr_kind_mod, only: r8=>shr_kind_r8, cl=>shr_kind_cl - use mo_gas_concentrations, only: ty_gas_concs - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - - - implicit none - private - public check_bounds_5d, check_bounds_4d, check_bounds_3d, check_bounds_2d, check_bounds_1d, check_bounds, & - assert_shape_2dreal, assert_shape - - ! bpm -- interface for checking array bounds - interface check_bounds - module procedure check_bounds_1d, check_bounds_2d, check_bounds_3d, check_bounds_4d, check_bounds_5d, check_bounds_gas_concs, check_bounds_gas_optics - end interface check_bounds - - interface assert_shape - module procedure assert_shape_2dreal - end interface assert_shape - - contains - - subroutine check_bounds_1d(arr, max_bound, min_bound, err_message) - real(r8), intent(in) :: arr(:) - real(r8), intent(in) :: max_bound, min_bound - character(len=128), intent(out) :: err_message - real(r8) :: mx, mn - err_message='' - mx = maxval(arr) - mn = minval(arr) - if (mn < min_bound) then - err_message = "validate: array values too small " - end if - if (mx > max_bound ) then - err_message = "validate: array values too large" - end if - end subroutine - - subroutine check_bounds_2d(arr, max_bound, min_bound, err_message) - real(r8), intent(in) :: arr(:,:) - real(r8), intent(in) :: max_bound, min_bound - character(len=128), intent(out) :: err_message - real(r8) :: mx, mn - err_message = '' - mx = maxval(arr) - mn = minval(arr) - if (mn < min_bound) then - err_message = "validate: array values too small " - end if - if (mx > max_bound ) then - err_message = "validate: array values too large" - end if - end subroutine - - subroutine check_bounds_3d(arr, max_bound, min_bound, err_message) - real(r8), intent(in) :: arr(:,:,:) - real(r8), intent(in) :: max_bound, min_bound - character(len=128), intent(out) :: err_message - real(r8) :: mx, mn - err_message = '' - mx = maxval(arr) - mn = minval(arr) - if (mn < min_bound) then - err_message = "validate: array values too small " - end if - if (mx > max_bound ) then - err_message = "validate: array values too large" - end if - end subroutine - - subroutine check_bounds_4d(arr, max_bound, min_bound, err_message) - real(r8), intent(in) :: arr(:,:,:,:) - real(r8), intent(in) :: max_bound, min_bound - character(len=128), intent(out) :: err_message - real(r8) :: mx, mn - err_message = '' - mx = maxval(arr) - mn = minval(arr) - if (mn < min_bound) then - err_message = "validate: array values too small " - end if - if (mx > max_bound ) then - err_message = "validate: array values too large" - end if - end subroutine - - subroutine check_bounds_5d(arr, max_bound, min_bound, err_message) - real(r8), intent(in) :: arr(:,:,:,:,:) - real(r8), intent(in) :: max_bound, min_bound - character(len=128), intent(out) :: err_message - real(r8) :: mx, mn - err_message = '' - mx = maxval(arr) - mn = minval(arr) - if (mn < min_bound) then - err_message = "validate: array values too small " - end if - if (mx > max_bound ) then - err_message = "validate: array values too large" - end if - end subroutine - - subroutine check_bounds_gas_concs(ncol, nlay, gasconcs, err_message) - integer, intent(in) :: ncol, nlay - type(ty_gas_concs), intent(in) :: gasconcs - character(len=128), intent(out) :: err_message - character(32), dimension(gasconcs%get_num_gases()) :: gc_gas_names - integer :: i - real(r8) :: vmr(ncol,nlay) - gc_gas_names(:) = gasconcs%get_gas_names() - do i = 1, gasconcs%get_num_gases() - err_message = gasconcs%get_vmr(gc_gas_names(i), vmr) ! gets values in vmr - if (len_trim(err_message) > 0) then - call endrun('check_bounds_gas_concs: error getting VMR for '//gc_gas_names(i)//' --> Error Message: '//trim(err_message)) - end if - call check_bounds(vmr, 1.0_r8, 0.0_r8, err_message) - if (len_trim(err_message) > 0) then - err_message = 'check_bounds_gas_concs: VMR error for '//gc_gas_names(i)//' --> Error Message: '//trim(err_message) - end if - end do - end subroutine - - subroutine check_bounds_gas_optics(kdist, err_message) - type(ty_gas_optics_rrtmgp), intent(in) :: kdist - character(len=128), intent(out) :: err_message - write(iulog,*) '[check_bonds_gas_optics DRAFT] : kdist' - ! write(iulog,*) 'number of gases: ',kdist%get_ngas() - ! write(iulog,*) 'gas names: ',kdist%get_gases() - ! write(iulog,*) 'kdist%source_is_external() = ',kdist%source_is_external() - err_message = "" - end subroutine - - - subroutine assert_shape_2dreal(arr, shp, err_message) - real(r8), intent(in) :: arr(:,:) ! 2-D array to check - integer, intent(in) :: shp(2) ! Expected shape - character(len=*), intent(out) :: err_message - character(len=512) :: err_append - integer :: r ! rank of arr - integer :: i - r = RANK(arr) - err_message = '' - if (r .ne. SIZE(shp)) then - err_message = 'Array is wrong rank (how could that happen?).' - end if - if (len_trim(err_message) == 0) then - do i = 1,r - if (SIZE(arr, i) /= shp(i)) then - write(err_append, "(a39,i3,a2)") 'Array size does not match on Dimension ', i, '._' - err_message = trim(err_message) // trim(err_append) - end if - end do - end if -end subroutine - -end module b_checker diff --git a/src/physics/rrtmgp/rad_solar_var.F90 b/src/physics/rrtmgp/rad_solar_var.F90 index 82c6b120d3..0cf996e901 100644 --- a/src/physics/rrtmgp/rad_solar_var.F90 +++ b/src/physics/rrtmgp/rad_solar_var.F90 @@ -4,6 +4,7 @@ !------------------------------------------------------------------------------- module rad_solar_var + use radconstants, only : nswbands use shr_kind_mod , only : r8 => shr_kind_r8 use solar_irrad_data, only : sol_irrad, we, nbins, has_spectrum, sol_tsi use solar_irrad_data, only : do_spctrl_scaling @@ -22,14 +23,12 @@ module rad_solar_var real(r8), allocatable :: radbinmax(:) real(r8), allocatable :: radbinmin(:) - integer :: nradbins !------------------------------------------------------------------------------- contains !------------------------------------------------------------------------------- subroutine rad_solar_var_init( ) - use radconstants, only : get_number_sw_bands use radconstants, only : get_sw_spectral_boundaries use radconstants, only : get_ref_solar_band_irrad use radconstants, only : get_ref_total_solar_irrad @@ -40,30 +39,28 @@ subroutine rad_solar_var_init( ) integer :: radmax_loc - call get_number_sw_bands(nradbins) - if ( do_spctrl_scaling ) then if ( .not.has_spectrum ) then call endrun('rad_solar_var_init: solar input file must have irradiance spectrum') endif - allocate (radbinmax(nradbins),stat=ierr) + allocate (radbinmax(nswbands),stat=ierr) if (ierr /= 0) then call endrun('rad_solar_var_init: Error allocating space for radbinmax') end if - allocate (radbinmin(nradbins),stat=ierr) + allocate (radbinmin(nswbands),stat=ierr) if (ierr /= 0) then call endrun('rad_solar_var_init: Error allocating space for radbinmin') end if - allocate (ref_band_irrad(nradbins), stat=ierr) + allocate (ref_band_irrad(nswbands), stat=ierr) if (ierr /= 0) then call endrun('rad_solar_var_init: Error allocating space for ref_band_irrad') end if - allocate (irrad(nradbins), stat=ierr) + allocate (irrad(nswbands), stat=ierr) if (ierr /= 0) then call endrun('rad_solar_var_init: Error allocating space for irrad') end if @@ -91,15 +88,15 @@ end subroutine rad_solar_var_init !------------------------------------------------------------------------------- subroutine get_variability( sfac ) - real(r8), intent(out) :: sfac(nradbins) ! scaling factors for CAM heating + real(r8), intent(out) :: sfac(nswbands) ! scaling factors for CAM heating integer :: yr, mon, day, tod if ( do_spctrl_scaling ) then - call integrate_spectrum( nbins, nradbins, we, radbinmin, radbinmax, sol_irrad, irrad) - sfac(:nradbins) = irrad(:nradbins)/ref_band_irrad(:nradbins) + call integrate_spectrum( nbins, nswbands, we, radbinmin, radbinmax, sol_irrad, irrad) + sfac(:nswbands) = irrad(:nswbands)/ref_band_irrad(:nswbands) else - sfac(:nradbins) = sol_tsi/tsi_ref + sfac(:nswbands) = sol_tsi/tsi_ref endif end subroutine get_variability diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index 1d1657fdc4..e573bfb792 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -20,9 +20,9 @@ module radconstants private save -! Number of bands in SW and LW (these will be set when RRTMGP initializes) -integer, public, protected :: nswbands = 14 -integer, public, protected :: nlwbands = 16 +! Number of bands in SW and LW (these will be checked when RRTMGP initializes) +integer, parameter, public :: nswbands = 14 +integer, parameter, public :: nlwbands = 16 ! Band limits (these get also get set at initialization) real(r8), public, allocatable :: wavenumber_low_shortwave(:) @@ -137,39 +137,23 @@ module radconstants public :: rad_gas_index -public :: get_number_sw_bands, & - get_sw_spectral_boundaries, & +public :: get_sw_spectral_boundaries, & get_lw_spectral_boundaries, & get_ref_solar_band_irrad, & get_ref_total_solar_irrad, & - ! get_solar_band_fraction_irrad, & get_idx_sw_diag, & get_idx_nir_diag, & get_idx_uv_diag, & get_idx_lw_diag, & get_band_index_by_value, & set_wavenumber_bands,& - get_number_lw_bands, & - set_number_lw_bands, & - set_number_sw_bands, & set_irrad_by_band, & set_reference_tsi +!=============================================================================== contains -!------------------------------------------------------------------------------ - ! COMMENT -- THIS CODE IS NOT USED. - ! subroutine get_solar_band_fraction_irrad(fractional_irradiance) - ! ! provide Solar Irradiance for each band in RRTMG - - ! ! fraction of solar irradiance in each band - ! real(r8), intent(out) :: fractional_irradiance(1:nswbands) - ! real(r8) :: tsi ! total solar irradiance - - ! tsi = sum(solar_ref_band_irradiance) - ! fractional_irradiance = solar_ref_band_irradiance / tsi +!=============================================================================== - ! end subroutine get_solar_band_fraction_irrad -!------------------------------------------------------------------------------ subroutine get_ref_total_solar_irrad(tsi) ! provide Total Solar Irradiance assumed by RRTMGP @@ -202,39 +186,9 @@ subroutine get_ref_solar_band_irrad( band_irrad ) end if end subroutine get_ref_solar_band_irrad -!------------------------------------------------------------------------------ -subroutine get_number_sw_bands(number_of_bands) - - ! number of solar (shortwave) bands - integer, intent(out) :: number_of_bands - number_of_bands = nswbands - -end subroutine get_number_sw_bands -!------------------------------------------------------------------------------ -subroutine set_number_sw_bands(number_of_bands) - ! set module data nswbands - ! expect: number_of_bands provided from RRTMGP optical properties object - integer, intent(in) :: number_of_bands - nswbands = number_of_bands -end subroutine set_number_sw_bands !------------------------------------------------------------------------------ -subroutine get_number_lw_bands(number_of_bands) - - ! number of longwave bands - integer, intent(out) :: number_of_bands - number_of_bands = nlwbands - -end subroutine get_number_lw_bands -!------------------------------------------------------------------------------ -subroutine set_number_lw_bands(number_of_bands) - ! set module data nlwbands - ! expect: number_of_bands provided from RRTMGP optical properties object - integer, intent(in) :: number_of_bands - nlwbands = number_of_bands -end subroutine set_number_lw_bands -!------------------------------------------------------------------------------ subroutine set_wavenumber_bands(swlw, nbands, values) ! set the low and high limits of the wavenumber grid for sw or lw ! expect that values comes from RRTMGP method get_band_lims_wavenumber @@ -307,7 +261,7 @@ subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) low_boundaries = 1._r8/wavenumber_high_shortwave high_boundaries = 1._r8/wavenumber_low_shortwave case default - call endrun('rad_constants.F90: spectral units not acceptable'//units) + call endrun('rad_constants.F90: requested spectral units not acceptable: '//units) end select end subroutine get_sw_spectral_boundaries diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index e3a631d4c4..2c49821be6 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -464,7 +464,7 @@ subroutine radiation_init(pbuf2d) use modal_aer_opt, only: modal_aer_opt_init use rrtmgp_inputs, only: rrtmgp_inputs_init use time_manager, only: is_first_step - use radconstants, only: set_number_sw_bands, set_number_lw_bands, set_wavenumber_bands, set_irrad_by_band, set_reference_tsi + use radconstants, only: set_wavenumber_bands, set_irrad_by_band, set_reference_tsi ! arguments type(physics_buffer_desc), pointer :: pbuf2d(:,:) @@ -530,10 +530,20 @@ subroutine radiation_init(pbuf2d) call coefs_init(coefs_sw_file, kdist_sw, available_gases, band2gpt_sw, ref_tsi) ! bpm : these now provide band2gpt which should be global call set_reference_tsi(ref_tsi) - ! set number of sw/lw bands in radconstants - call set_number_sw_bands(kdist_sw%get_nband()) - call set_number_lw_bands(kdist_lw%get_nband()) - write(iulog, *) 'rad_init: NUMBER SW BANDS: ',kdist_sw%get_nband(),' NUMBER LW BANDS: ',kdist_lw%get_nband() + ! check number of sw/lw bands in gas optics files + if (kdist_sw%get_nband() /= nswbands) then + write(errmsg,'(a,i4,a,i4)') 'number of sw bands in file, ', kdist_sw%get_nband(), & + ", doesn't match parameter nswbands= ", nswbands + call endrun(sub//': ERROR: '//trim(errmsg)) + end if + if (kdist_lw%get_nband() /= nlwbands) then + write(errmsg,'(a,i4,a,i4)') 'number of lw bands in file, ', kdist_lw%get_nband(), & + ", doesn't match parameter nlwbands= ", nlwbands + call endrun(sub//': ERROR: '//trim(errmsg)) + end if + if (masterproc) then + write(iulog, *) sub//': NUMBER SW BANDS: ', nswbands,' NUMBER LW BANDS: ', nlwbands + end if ! set the sw/lw band limits in radconstants call set_wavenumber_bands('sw', kdist_sw%get_nband(), kdist_sw%get_band_lims_wavenumber()) @@ -1495,50 +1505,6 @@ subroutine radiation_tend( & call clipper(cloud_sw%ssa, 0._r8, 1._r8) call clipper(cloud_sw%g, -1._r8, 1._r8) - ! CHECK BOUNDS OF ARRAYS: - ! errmsg = cloud_sw%validate() ! rte provides validate method for tau, ssa, and g all at once. - ! if (len_trim(errmsg) > 0) then - ! call endrun(sub//': ERROR code returned by check_bounds cloud_sw: '//trim(errmsg)) - ! end if - ! errmsg = aer_sw%validate() ! rte provides validate method for tau, ssa, and g all at once. - ! if (len_trim(errmsg) > 0) then - ! call endrun(sub//': ERROR code returned by check_bounds aer_sw: '//trim(errmsg)) - ! end if - ! call check_bounds(alb_dir, 1.0_r8, 0.0_r8, errmsg) - ! if (len_trim(errmsg) > 0) then - ! call endrun(sub//': ERROR code returned by check_bounds alb_dir: '//trim(errmsg)) - ! end if - ! call check_bounds(alb_dif, 1.0_r8, 0.0_r8, errmsg) - ! if (len_trim(errmsg) > 0) then - ! call endrun(sub//': ERROR code returned by check_bounds alb_dif: '//trim(errmsg)) - ! end if - ! call check_bounds(coszrs_day, 1.0_r8, 0.0_r8, errmsg) - ! if (len_trim(errmsg) > 0) then - ! call endrun(sub//': ERROR code returned by check_bounds coszrs_day: '//trim(errmsg)) - ! end if - ! call check_bounds(pint_day, 120000.0_r8, 1.0_r8, errmsg) ! Pa -- give pretty big bounds - ! if (len_trim(errmsg) > 0) then - ! call endrun(sub//': ERROR code returned by check_bounds pint_day: '//trim(errmsg)) - ! end if - ! call check_bounds(t_day, 350.0_r8, 150.0_r8, errmsg) ! K -- give pretty big bounds - ! if (len_trim(errmsg) > 0) then - ! call endrun(sub//': ERROR code returned by check_bounds t_day: '//trim(errmsg)) - ! end if - ! call check_bounds(pmid_day, 120000.0_r8, 1.0_r8, errmsg) ! Pa -- give pretty big bounds - ! if (len_trim(errmsg) > 0) then - ! call endrun(sub//': ERROR code returned by check_bounds pint_day: '//trim(errmsg)) - ! end if - - - ! Still to validate: - ! - kdist_sw - ! - gas_concs_sw - ! call check_bounds(nday, nlay, gas_concs_sw, errmsg) - ! if (len_trim(errmsg) > 0) then - ! call endrun(sub//': ERROR code returned by check_bounds gas_concs_sw: '//trim(errmsg)) - ! end if - ! call check_bounds(kdist_sw, errmsg) -! call shr_mem_getusage(mem_hw_beg, mem_beg) ! inputs are the daylit columns --> output fluxes therefore also on daylit columns. errmsg = rte_sw( kdist_sw, & ! input (from init) gas_concs_sw, & ! input, (from rrtmgp_set_gases_sw) @@ -1555,18 +1521,6 @@ subroutine radiation_tend( & tsi_scaling=eccf & !< optional input, scaling for irradiance ) -! call shr_mem_getusage(mem_hw_end, mem_end) -! temp = mem_hw_end - mem_hw_beg -! if (masterproc) then -! write(iulog, *) 'rte_sw: Increase in memory highwater = ', & -! temp, ' (MB)' -! end if -! temp = mem_end - mem_beg -! if (masterproc) then -! write(iulog, *) 'rte_sw: Increase in memory usage = ', & -! temp, ' (MB)' -! end if - if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR code returned by rte_sw: '//trim(errmsg)) end if @@ -1667,7 +1621,7 @@ subroutine radiation_tend( & cloud_lw & ! inout (%tau is set, and returned bottom-to-top) ) - ! initialize/allocate object for aerosol optics (note, don't just give it nlwbands b/c wrong type) + ! initialize/allocate object for aerosol optics errmsg = aer_lw%alloc_1scl(ncol, & nlay, & kdist_lw%get_band_lims_wavenumber(), & @@ -1821,9 +1775,6 @@ subroutine radiation_tend( & end if ! if (dosw .or. dolw) then - ! write(iulog,*) 'Radiation_Tend finished calculation [timestep ',get_nstep(), ', chunk: ',lchnk,'] -- qrs max: ',maxval(qrs),' min: ',minval(qrs),' -- qrl max: ',maxval(qrl), ' min: ',minval(qrl) - - ! ------------------------------------------------------------------------ ! ! After any radiative transfer is done: output & convert fluxes to heating @@ -1870,8 +1821,6 @@ subroutine radiation_tend( & call free_fluxes(flw) call free_fluxes(flwc) - ! write(iulog,*) 'Radiation_Tend END [timestep ',get_nstep(), ', chunk: ',lchnk,']' - !------------------------------------------------------------------------------- contains !------------------------------------------------------------------------------- From 3022b4c8484e864d312b8093b8702a374ec51db8 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 5 Jul 2023 11:01:23 -0400 Subject: [PATCH 06/53] remove references to b_checker --- src/physics/rrtmgp/rrtmgp_inputs.F90 | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 90d87fcf07..116093add4 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -38,7 +38,6 @@ module rrtmgp_inputs use cam_abortutils, only: endrun use cam_history, only: outfld ! just for getting ozone VMR above model top. -use b_checker, only: assert_shape ! checking on shapes implicit none private @@ -149,25 +148,6 @@ subroutine rrtmgp_set_state( & character(len=512) :: errmsg !-------------------------------------------------------------------------------- - ! - ! bpm note: the size of pstate%t 's 1st dimension can be larger than ncol. Assume we are only interested in 1:ncol. - ! - ! call assert_shape(pstate%t, (/ncol, pver/), errmsg) - ! if (len_trim(errmsg) > 0) then - ! write(iulog,*) '['//sub//'] : pstate%t -- shape: ',SHAPE(pstate%t),'[EXPECTED: (',ncol,'x',pver,')] max: ',maxval(pstate%t),' min: ',minval(pstate%t) - ! call endrun(sub//trim(errmsg)) - ! end if - ! call assert_shape(pstate%pmid, (/ncol, pver/), errmsg) - ! if (len_trim(errmsg) > 0) then - ! write(iulog,*) '['//sub//'] : pstate%pmid -- shape: ',SHAPE(pstate%pmid),' max: ',maxval(pstate%pmid),' min: ',minval(pstate%pmid) - ! call endrun(sub//trim(errmsg)) - ! end if - ! call assert_shape(pstate%pint, (/ncol, pverp/), errmsg) - ! if (len_trim(errmsg) > 0) then - ! write(iulog,*) '['//sub//'] : pstate%pint -- shape: ',SHAPE(pstate%pint),' max: ',maxval(pstate%pint),' min: ',minval(pstate%pint) - ! call endrun(sub//trim(errmsg)) - ! end if - t_sfc = sqrt(sqrt(cam_in%lwup(:ncol)/stebol)) ! Surface temp set based on longwave up flux. ! Set surface emissivity to 1.0. From fd417ba4c9ec127a70de6fb9f63605d7d300e00a Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 19 Jul 2023 19:17:00 -0400 Subject: [PATCH 07/53] add configure option rrtmgp_smp; misc cleanup --- bld/configure | 17 +++++-- bld/namelist_files/use_cases/1850_cam5.xml | 54 ++++++++++++++++++++++ src/chemistry/utils/solar_data.F90 | 1 + src/physics/rrtmg/radiation.F90 | 6 --- src/physics/rrtmgp/radiation.F90 | 50 +++++++++----------- 5 files changed, 91 insertions(+), 37 deletions(-) create mode 100644 bld/namelist_files/use_cases/1850_cam5.xml diff --git a/bld/configure b/bld/configure index 11923363dd..d7ff1c0f9e 100755 --- a/bld/configure +++ b/bld/configure @@ -103,7 +103,7 @@ OPTIONS -prog_species Comma-separate list of prognostic mozart species packages. Currently available: DST,SSLT,SO4,GHG,OC,BC,CARBON16 -psubcols Maximum number of sub-columns in a run - set to 1 if not using sub-columns (default) - -rad Specify the radiation package [rrtmg | rrtmgp | camrt] + -rad Specify the radiation package [rrtmg | rrtmgp | rrtmgp_smp | camrt] -silhs Switch on SILHS. -spcam_clubb_sgs Turn on the SPCAM version of CLUBB -spcam_nx SPCAM x-grid. - defaults to 4 (note the CRM requires spcam_nx to be greater than or equal to 4) @@ -1066,8 +1066,16 @@ elsif ($phys_pkg =~ m/^cam[56]$|^cam_dev$|^spcam_m2005$/) { $rad_pkg = 'rrtmg'; } # Allow the user to override the default via the commandline. +my $use_rrtmgp_smp = 0; if (defined $opts{'rad'}) { $rad_pkg = lc($opts{'rad'}); + # If the radiation package is set to rrtmgp_smp then will add the smp code version + # (openmp and openacc) to the Filepath file, but strip off the "_smp" when setting + # the radiation package name in the config_cache file. + if ($rad_pkg eq 'rrtmgp_smp') { + $use_rrtmgp_smp = 1; + $rad_pkg =~ s!_smp!! + } } # consistency checks... @@ -2180,11 +2188,14 @@ sub write_filepath } elsif ($rad eq 'rrtmgp') { print $fh "$camsrcdir/src/physics/rrtmgp\n"; - print $fh "$camsrcdir/src/physics/rrtmgp/ext\n"; print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp\n"; print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte\n"; - print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte/kernels\n"; + if ($use_rrtmgp_smp) { + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp/kernels-openacc\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte/kernels-openacc\n"; + } print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp/kernels\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte/kernels\n"; print $fh "$camsrcdir/src/physics/rrtmgp/ext/extensions\n"; print $fh "$camsrcdir/src/physics/rrtmgp/ext/extensions/cloud_optics\n"; } diff --git a/bld/namelist_files/use_cases/1850_cam5.xml b/bld/namelist_files/use_cases/1850_cam5.xml new file mode 100644 index 0000000000..f33151bb3d --- /dev/null +++ b/bld/namelist_files/use_cases/1850_cam5.xml @@ -0,0 +1,54 @@ + + + + + +atm/cam/solar/SOLAR_SPECTRAL_Lean_1610-2008_annual_c090324.nc +18500101 +FIXED + + +284.7e-6 +791.6e-9 +275.68e-9 +12.48e-12 +0.0 + + +atm/cam/ozone +ozone_1.9x2.5_L26_1850clim_c090420.nc +O3 +CYCLICAL +1850 + + +CYCLICAL +atm/cam/chem/trop_mozart_aero/emis/aerocom_mam3_dms_surf_2000_c090129.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so2_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_soag_1.5_surf_1850_c100217.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_bc_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_oc_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so4_a1_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so4_a2_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_num_a1_surf_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_num_a2_surf_1850_c090726.nc + + +CYCLICAL +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so2_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so4_a1_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_so4_a2_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_num_a1_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_num_a2_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_oc_elev_1850_c090726.nc +atm/cam/chem/trop_mozart_aero/emis/ar5_mam3_bc_elev_1850_c090726.nc + + +CYCLICAL +1850 +oxid_1.9x2.5_L26_1850clim_c091123.nc + + +1850 + + diff --git a/src/chemistry/utils/solar_data.F90 b/src/chemistry/utils/solar_data.F90 index da18fbc777..51ad7ad82b 100644 --- a/src/chemistry/utils/solar_data.F90 +++ b/src/chemistry/utils/solar_data.F90 @@ -91,6 +91,7 @@ subroutine solar_data_readnl( nlfile ) write(iulog,*) 'solar_data_readnl: solar_data_type = ',trim(solar_data_type) write(iulog,*) 'solar_data_readnl: solar_data_ymd = ',solar_data_ymd write(iulog,*) 'solar_data_readnl: solar_data_tod = ',solar_data_tod + write(iulog,*) 'solar_data_readnl: solar_htng_spctrl_scl = ',solar_htng_spctrl_scl endif solar_parms_on = solar_parms_data_file.ne.'NONE' diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index 137e4a01d6..31e33b183d 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -1215,12 +1215,6 @@ subroutine radiation_tend( & rd%aer_tau400(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag+1) rd%aer_tau700(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag-1) - print*,'--- Right before rad_rrtmg_sw ---' - do k=1,pver - print '("LEVEL",i2,3x,"TAU (max) = ",f7.4,3x)', k,MAXVAL(c_cld_tau(:,1,k)) - end do - - call rad_rrtmg_sw( & lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & cldfprime, aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 2c49821be6..cb65b9108e 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -196,14 +196,18 @@ module radiation ! Number of layers in radiation calculations. integer :: nlay -! Indices for copying data between cam and rrtmgp arrays -! The code currently assumes the rrtmgp vertical index goes bottom to top, -! while CAM goes top-to-bottom ... -! Newer RRTMGP checks for host model order and adjusts, so a lot of the assumptions are unncessary. -integer :: ktopcamm ! cam index of top layer -integer :: ktopradm ! rrtmgp index of layer corresponding to ktopcamm -integer :: ktopcami ! cam index of top interface -integer :: ktopradi ! rrtmgp index of interface corresponding to ktopcami +! Indices for copying data between CAM/WACCM and RRTMGP arrays. Since RRTMGP is +! vertical order agnostic we can send data using the top to bottom order used +! in CAM/WACCM. But the number of layers that RRTMGP does computations for +! may not match the number of layers in CAM/WACCM for two reasons: +! 1. If the CAM model top is below 1 Pa, then RRTMGP does calculations for an +! extra layer that is added between 1 Pa and the model top. +! 2. If the WACCM model top is above 1 Pa, then RRMTGP only does calculations +! for those model layers that are below 1 Pa. +integer :: ktopcamm ! index in CAM arrays of top layer at which RRTMGP is active +integer :: ktopcami ! index in CAM arrays of top interface at which RRTMGP is active +integer :: ktopradm ! index in RRTMGP arrays of layer corresponding to CAM top layer +integer :: ktopradi ! index in RRTMGP arrays of interface corresponding to CAM top interface ! LW coefficients type(ty_gas_optics_rrtmgp) :: kdist_lw ! bpm changed here @@ -287,7 +291,7 @@ subroutine radiation_readnl(nlfile) call mpi_bcast(rrtmgp_coefs_lw_file, cl, mpi_character, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: rrtmgp_coefs_lw_file") call mpi_bcast(rrtmgp_coefs_sw_file, cl, mpi_character, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: coefs_sw_file") + if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: rrtmgp_coefs_sw_file") call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: iradsw") call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) @@ -493,36 +497,26 @@ subroutine radiation_init(pbuf2d) character(len=*), parameter :: sub = 'radiation_init' !----------------------------------------------------------------------- - ! - ! replacement of RRTMG's rrtmg_state_init - ! - ! Number of layers in radiation calculation is capped by the number of ! pressure interfaces below 1 Pa. When the entire model atmosphere is ! below 1 Pa then an extra layer is added to the top of the model for ! the purpose of the radiation calculation. nlay = count( pref_edge(:) > 1._r8 ) ! pascals (0.01 mbar) - ! Use k*rad* to access variables ON THE RADIATION GRID - ! Use k*cam* to access variables ON THE CAM GRID if (nlay == pverp) then - ktopcamm = 1 ! interpretation: highest CAM grid layer at which radiation is active - ktopcami = 1 - ktopradm = nlay + 1 - pver ! radiation grid layer the corresponds to CAM's highest layer (expected to be 2) - ktopradi = nlay + 1 - pver - else ! nlay < pverp - ! nlay layers are set by radiation - ! nlay+1 interfaces are set by radiation + ! Top model interface is below 1 Pa. RRTMGP is active in all model layers plus + ! 1 extra layer between model top and 1 Pa. + ktopcamm = 1 + ktopcami = 1 + ktopradm = 2 + ktopradi = 2 + else + ! nlay < pverp. nlay layers are set by radiation ktopcamm = pverp - nlay + 1 ktopcami = pverp - nlay + 1 - ktopradm = 1 ! radiation grid index at top is just 1 + ktopradm = 1 ktopradi = 1 end if - ! bottom indices are known, so we don't need to have extra variables. - ! kbotcamm = pver - ! kbotcami = pverp - ! kbotradm = nlay - ! kbotradi = nlay + 1 call set_available_gases(active_gases, available_gases) ! gases needed to initialize spectral info From 8d315350292ae1bd0bbc263ee436be8a174a7a8c Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 28 Jul 2023 18:30:12 -0400 Subject: [PATCH 08/53] change rrtmgp_smp to rrtmgp_gpu; fix SW TOA output vars --- bld/configure | 16 ++++++++-------- src/physics/rrtmgp/radiation.F90 | 8 ++++---- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/bld/configure b/bld/configure index 5632254270..a6a4ee804d 100755 --- a/bld/configure +++ b/bld/configure @@ -103,7 +103,7 @@ OPTIONS -prog_species Comma-separate list of prognostic mozart species packages. Currently available: DST,SSLT,SO4,GHG,OC,BC,CARBON16 -psubcols Maximum number of sub-columns in a run - set to 1 if not using sub-columns (default) - -rad Specify the radiation package [rrtmg | rrtmgp | rrtmgp_smp | camrt] + -rad Specify the radiation package [rrtmg | rrtmgp | rrtmgp_gpu | camrt] -silhs Switch on SILHS. -spcam_clubb_sgs Turn on the SPCAM version of CLUBB -spcam_nx SPCAM x-grid. - defaults to 4 (note the CRM requires spcam_nx to be greater than or equal to 4) @@ -1066,15 +1066,15 @@ elsif ($phys_pkg =~ m/^cam[56]$|^cam_dev$|^spcam_m2005$/) { $rad_pkg = 'rrtmg'; } # Allow the user to override the default via the commandline. -my $use_rrtmgp_smp = 0; +my $use_rrtmgp_gpu = 0; if (defined $opts{'rad'}) { $rad_pkg = lc($opts{'rad'}); - # If the radiation package is set to rrtmgp_smp then will add the smp code version - # (openmp and openacc) to the Filepath file, but strip off the "_smp" when setting + # If the radiation package is set to rrtmgp_gpu then will add the gpu code version + # (openmp and openacc) to the Filepath file, but strip off the "_gpu" when setting # the radiation package name in the config_cache file. - if ($rad_pkg eq 'rrtmgp_smp') { - $use_rrtmgp_smp = 1; - $rad_pkg =~ s!_smp!! + if ($rad_pkg eq 'rrtmgp_gpu') { + $use_rrtmgp_gpu = 1; + $rad_pkg =~ s!_gpu!! } } @@ -2214,7 +2214,7 @@ sub write_filepath print $fh "$camsrcdir/src/physics/rrtmgp\n"; print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp\n"; print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte\n"; - if ($use_rrtmgp_smp) { + if ($use_rrtmgp_gpu) { print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp/kernels-openacc\n"; print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte/kernels-openacc\n"; } diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index cb65b9108e..b7883aed45 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1855,10 +1855,10 @@ subroutine set_sw_diags() fswc%flux_dn(i,ktopradi:) fsds(idxday(i)) = fsw%flux_dn(i, nlay+1) rd%fsdsc(idxday(i)) = fswc%flux_dn(i, nlay+1) - rd%fsutoa(idxday(i)) = fsw%flux_up(i, ktopradi) - rd%fsntoa(idxday(i)) = fsw%flux_net(i, ktopradi) ! net sw flux at TOA (*NOT* the same as fsnt) - rd%fsntoac(idxday(i)) = fswc%flux_net(i, ktopradi) ! net sw clearsky flux at TOA (*NOT* the same as fsntc) - rd%solin(idxday(i)) = fswc%flux_dn(i, ktopradi) + rd%fsutoa(idxday(i)) = fsw%flux_up(i, 1) + rd%fsntoa(idxday(i)) = fsw%flux_net(i, 1) ! net sw flux at TOA (*NOT* the same as fsnt) + rd%fsntoac(idxday(i)) = fswc%flux_net(i, 1) ! net sw clearsky flux at TOA (*NOT* the same as fsntc) + rd%solin(idxday(i)) = fswc%flux_dn(i, 1) end do call heating_rate('SW', ncol, fns, qrs) From d46aa4b29d32c3c49aa34872053d1ec1e976a8c2 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 14 Aug 2023 15:34:44 -0400 Subject: [PATCH 09/53] add diagnostic output for fluxes on the RRTMGP grid --- src/physics/rrtmgp/radiation.F90 | 111 +++++++++++++++++++++++-------- 1 file changed, 85 insertions(+), 26 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index b7883aed45..9ff948d333 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -46,7 +46,7 @@ module radiation use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active -use cam_history_support, only: fillvalue +use cam_history_support, only: fillvalue, add_vert_coord use ioFileMod, only: getfil use cam_pio_utils, only: cam_pio_openfile @@ -126,11 +126,21 @@ module radiation real(r8) :: flux_sw_dn(pcols,pverp) ! downward flux real(r8) :: flux_sw_clr_dn(pcols,pverp) ! downward clearsky flux + real(r8), allocatable :: fsdn(:,:) ! Downward SW flux on rrtmgp grid + real(r8), allocatable :: fsdnc(:,:) ! Downward SW clear sky flux on rrtmgp grid + real(r8), allocatable :: fsup(:,:) ! Upward SW flux on rrtmgp grid + real(r8), allocatable :: fsupc(:,:) ! Upward SW clear sky flux on rrtmgp grid + 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_dn(pcols,pverp) ! downward flux real(r8) :: flux_lw_clr_dn(pcols,pverp) ! downward clearsky flux + real(r8), allocatable :: fldn(:,:) ! Downward LW flux on rrtmgp grid + real(r8), allocatable :: fldnc(:,:) ! Downward LW clear sky flux on rrtmgp grid + real(r8), allocatable :: flup(:,:) ! Upward LW flux on rrtmgp grid + real(r8), allocatable :: flupc(:,:) ! Upward LW clear sky flux on rrtmgp grid + real(r8) :: qrlc(pcols,pver) real(r8) :: flntc(pcols) ! Clear sky lw flux at model top @@ -209,6 +219,9 @@ module radiation integer :: ktopradm ! index in RRTMGP arrays of layer corresponding to CAM top layer integer :: ktopradi ! index in RRTMGP arrays of interface corresponding to CAM top interface +! vertical coordinate for output of fluxes on radiation grid +real(r8), allocatable, target :: plev_rad(:) + ! LW coefficients type(ty_gas_optics_rrtmgp) :: kdist_lw ! bpm changed here integer :: ngpt_lw @@ -349,11 +362,11 @@ end subroutine radiation_readnl subroutine radiation_register - ! Register radiation fields in the physics buffer - use physics_buffer, only: pbuf_add_field, dtype_r8 use radiation_data, only: rad_data_register + ! Register radiation fields in the physics buffer + call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate @@ -502,6 +515,7 @@ subroutine radiation_init(pbuf2d) ! below 1 Pa then an extra layer is added to the top of the model for ! the purpose of the radiation calculation. nlay = count( pref_edge(:) > 1._r8 ) ! pascals (0.01 mbar) + allocate(plev_rad(nlay+1)) if (nlay == pverp) then ! Top model interface is below 1 Pa. RRTMGP is active in all model layers plus @@ -510,14 +524,21 @@ subroutine radiation_init(pbuf2d) ktopcami = 1 ktopradm = 2 ktopradi = 2 + plev_rad(1) = 1.01_r8 ! Top of extra layer, Pa. + plev_rad(2:) = pref_edge else ! nlay < pverp. nlay layers are set by radiation ktopcamm = pverp - nlay + 1 ktopcami = pverp - nlay + 1 ktopradm = 1 ktopradi = 1 + plev_rad = pref_edge(ktopcami:) end if + ! Define a pressure coordinate to allow output of data on the radiation grid. + call add_vert_coord('plev_rad', nlay+1, 'Pressures at radiation flux calculations', & + 'Pa', plev_rad) + call set_available_gases(active_gases, available_gases) ! gases needed to initialize spectral info call coefs_init(coefs_lw_file, kdist_lw, available_gases, band2gpt_lw) @@ -690,6 +711,12 @@ subroutine radiation_init(pbuf2d) call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') + ! Fluxes on rrtmgp grid + call addfld('FSDN'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW downward flux on rrtmgp grid') + call addfld('FSDNC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW downward clear sky flux on rrtmgp grid') + call addfld('FSUP'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW upward flux on rrtmgp grid') + call addfld('FSUPC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW upward clear sky flux on rrtmgp grid') + if (history_amwg) then call add_default('SOLIN'//diag(icall), 1, ' ') call add_default('QRS'//diag(icall), 1, ' ') @@ -746,6 +773,12 @@ subroutine radiation_init(pbuf2d) call addfld('FULC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Longwave clear-sky upward flux') call addfld('FDLC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Longwave clear-sky downward flux') + ! Fluxes on rrtmgp grid + call addfld('FLDN'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'LW downward flux on rrtmgp grid') + call addfld('FLDNC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'LW downward clear sky flux on rrtmgp grid') + call addfld('FLUP'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'LW upward flux on rrtmgp grid') + call addfld('FLUPC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'LW upward clear sky flux on rrtmgp grid') + if (history_amwg) then call add_default('QRL'//diag(icall), 1, ' ') call add_default('FLNT'//diag(icall), 1, ' ') @@ -1095,6 +1128,11 @@ subroutine radiation_tend( & write_output = .false. else allocate(rd) + ! allocate some elements of rd + if (.not. allocated(rd%fsdn)) then + allocate(rd%fsdn(pcols,nlay+1), rd%fsdnc(pcols,nlay+1), rd%fsup(pcols,nlay+1), rd%fsupc(pcols,nlay+1), & + rd%fldn(pcols,nlay+1), rd%fldnc(pcols,nlay+1), rd%flup(pcols,nlay+1), rd%flupc(pcols,nlay+1) ) + end if write_output = .true. end if @@ -1831,34 +1869,39 @@ subroutine set_sw_diags() size(fsw%bnd_flux_dn,2), & size(fsw%bnd_flux_dn,3)) :: flux_dn_diffuse !------------------------------------------------------------------------- - fns = 0._r8 ! net sw flux - fcns = 0._r8 ! net sw clearsky flux - fsds = 0._r8 ! downward sw flux at surface - rd%fsdsc = 0._r8 ! downward sw clearsky flux at surface - rd%fsutoa = 0._r8 ! upward sw flux at TOA - rd%fsntoa = 0._r8 ! net sw at TOA - rd%fsntoac = 0._r8 ! net sw clearsky flux at TOA - rd%solin = 0._r8 ! solar irradiance at TOA + + ! Initializing these arrays to 0.0 provides fill in the night columns: + fns = 0._r8 ! net sw flux + fcns = 0._r8 ! net sw clearsky flux + fsds = 0._r8 ! downward sw flux at surface + rd%fsdsc = 0._r8 ! downward sw clearsky flux at surface + rd%fsutoa = 0._r8 ! upward sw flux at TOA + rd%fsntoa = 0._r8 ! net sw at TOA + rd%fsntoac = 0._r8 ! net sw clearsky flux at TOA + rd%solin = 0._r8 ! solar irradiance at TOA + rd%fsdn = 0._r8 + rd%fsdnc = 0._r8 + rd%fsup = 0._r8 + rd%fsupc = 0._r8 ! fns, fcns, rd are on CAM grid (do not have "extra layer" when it is present.) - ! fill in the daylit columns: do i = 1, nday fns(idxday(i),ktopcami:) = fsw%flux_net(i, ktopradi:) fcns(idxday(i),ktopcami:) = fswc%flux_net(i,ktopradi:) - rd%flux_sw_up(idxday(i),ktopcami:) = & - fsw%flux_up(i,ktopradi:) - rd%flux_sw_dn(idxday(i),ktopcami:) = & - fsw%flux_dn(i,ktopradi:) - rd%flux_sw_clr_up(idxday(i),ktopcami:) = & - fswc%flux_up(i,ktopradi:) - rd%flux_sw_clr_dn(idxday(i),ktopcami:) = & - fswc%flux_dn(i,ktopradi:) - fsds(idxday(i)) = fsw%flux_dn(i, nlay+1) - rd%fsdsc(idxday(i)) = fswc%flux_dn(i, nlay+1) - rd%fsutoa(idxday(i)) = fsw%flux_up(i, 1) - rd%fsntoa(idxday(i)) = fsw%flux_net(i, 1) ! net sw flux at TOA (*NOT* the same as fsnt) - rd%fsntoac(idxday(i)) = fswc%flux_net(i, 1) ! net sw clearsky flux at TOA (*NOT* the same as fsntc) - rd%solin(idxday(i)) = fswc%flux_dn(i, 1) + fsds(idxday(i)) = fsw%flux_dn(i, nlay+1) + rd%fsdsc(idxday(i)) = fswc%flux_dn(i, nlay+1) + rd%fsutoa(idxday(i)) = fsw%flux_up(i, 1) + rd%fsntoa(idxday(i)) = fsw%flux_net(i, 1) ! net sw flux at TOA (*NOT* the same as fsnt) + rd%fsntoac(idxday(i)) = fswc%flux_net(i, 1) ! net sw clearsky flux at TOA (*NOT* the same as fsntc) + rd%solin(idxday(i)) = fswc%flux_dn(i, 1) + rd%flux_sw_up(idxday(i),ktopcami:) = fsw%flux_up(i,ktopradi:) + rd%flux_sw_dn(idxday(i),ktopcami:) = fsw%flux_dn(i,ktopradi:) + rd%flux_sw_clr_up(idxday(i),ktopcami:) = fswc%flux_up(i,ktopradi:) + rd%flux_sw_clr_dn(idxday(i),ktopcami:) = fswc%flux_dn(i,ktopradi:) + rd%fsdn(idxday(i),:) = fsw%flux_dn(i,:) + rd%fsdnc(idxday(i),:) = fswc%flux_dn(i,:) + rd%fsup(idxday(i),:) = fsw%flux_up(i,:) + rd%fsupc(idxday(i),:) = fswc%flux_up(i,:) end do call heating_rate('SW', ncol, fns, qrs) @@ -1962,6 +2005,11 @@ subroutine set_lw_diags() rd%flut(:ncol) = flw%flux_up(:, ktopradi) rd%flutc(:ncol) = flwc%flux_up(:, ktopradi) + rd%fldn(:ncol,:) = flw%flux_dn + rd%fldnc(:ncol,:) = flwc%flux_dn + rd%flup(:ncol,:) = flw%flux_up + rd%flupc(:ncol,:) = flwc%flux_up + ! Output fluxes at 200 mb call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) @@ -2090,6 +2138,11 @@ subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) call outfld('FDS'//diag(icall), rd%flux_sw_dn, pcols, lchnk) call outfld('FDSC'//diag(icall), rd%flux_sw_clr_dn, pcols, lchnk) + call outfld('FSDN'//diag(icall), rd%fsdn, pcols, lchnk) + call outfld('FSDNC'//diag(icall), rd%fsdnc, pcols, lchnk) + call outfld('FSUP'//diag(icall), rd%fsup, pcols, lchnk) + call outfld('FSUPC'//diag(icall), rd%fsupc, pcols, lchnk) + end subroutine radiation_output_sw @@ -2169,6 +2222,12 @@ subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out) call outfld('FDLC'//diag(icall), rd%flux_lw_clr_dn, pcols, lchnk) call outfld('FUL'//diag(icall), rd%flux_lw_up, pcols, lchnk) call outfld('FULC'//diag(icall), rd%flux_lw_clr_up, pcols, lchnk) + + call outfld('FLDN'//diag(icall), rd%fldn, pcols, lchnk) + call outfld('FLDNC'//diag(icall), rd%fldnc, pcols, lchnk) + call outfld('FLUP'//diag(icall), rd%flup, pcols, lchnk) + call outfld('FLUPC'//diag(icall), rd%flupc, pcols, lchnk) + end subroutine radiation_output_lw !=============================================================================== From 42e49768edde02fed6208e1bf6216e83820f0fe2 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 15 Aug 2023 10:16:46 -0400 Subject: [PATCH 10/53] update rrtmgp external to use local_fix01 --- Externals_CAM.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 0fde1a5489..758c04b9c3 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -2,7 +2,7 @@ local_path = src/physics/rrtmgp/ext protocol = git repo_url = https://github.com/brian-eaton/rte-rrtmgp.git -tag = build_mod01 +tag = local_fix01 required = True [chem_proc] From 19b908333bdc0ca75fd9631a62535c636d3c4a1c Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 16 Aug 2023 09:31:53 -0400 Subject: [PATCH 11/53] fix in rrtmgp_driver.F90 for gpu --- src/physics/rrtmgp/rrtmgp_driver.F90 | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/physics/rrtmgp/rrtmgp_driver.F90 b/src/physics/rrtmgp/rrtmgp_driver.F90 index 12f16e7b5c..c7e0ed5324 100644 --- a/src/physics/rrtmgp/rrtmgp_driver.F90 +++ b/src/physics/rrtmgp/rrtmgp_driver.F90 @@ -40,9 +40,9 @@ module rrtmgp_driver use cam_logfile, only: iulog implicit none - private public :: rte_lw, rte_sw + contains ! -------------------------------------------------- ! @@ -95,11 +95,7 @@ function rte_lw(k_dist, gas_concs, p_lay, t_lay, p_lev, & ngpt = k_dist%get_ngpt() nband = k_dist%get_nband() - !$acc kernels copyout(top_at_1) - !$omp target map(from:top_at_1) top_at_1 = p_lay(1, 1) < p_lay(1, nlay) - !$acc end kernels - !$omp end target ! ------------------------------------------------------------------------------------ ! Error checking From 6b36f66af961304bcfa4340152de28e25e993632 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 24 Aug 2023 13:35:18 -0400 Subject: [PATCH 12/53] cleanup a couple of unused vars --- src/physics/rrtmgp/radiation.F90 | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 9ff948d333..baf9620389 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -224,7 +224,6 @@ module radiation ! LW coefficients type(ty_gas_optics_rrtmgp) :: kdist_lw ! bpm changed here -integer :: ngpt_lw ! SW coefficients type(ty_gas_optics_rrtmgp) :: kdist_sw ! bpm changed here @@ -570,7 +569,6 @@ subroutine radiation_init(pbuf2d) call rad_data_init(pbuf2d) ! initialize output fields for offline driver call cloud_rad_props_init() - ngpt_lw = kdist_lw%get_ngpt() ! these set global values ngpt_sw = kdist_sw%get_ngpt() ! bpm: set the indices used for diagnostics using specific band: @@ -1114,21 +1112,19 @@ subroutine radiation_tend( & logical :: conserve_energy = .false. ! Flag to carry (QRS,QRL)*dp across time steps. integer :: iband - integer :: nlevcam, nlevrad real(r8) :: mem_hw_end, mem_hw_beg, mem_end, mem_beg, temp !-------------------------------------------------------------------------------------- lchnk = state%lchnk ncol = state%ncol - nlevcam = size(state%t,2) ! number of levels in CAM grid if (present(rd_out)) then rd => rd_out write_output = .false. else allocate(rd) - ! allocate some elements of rd + ! allocate elements of rd for output of fluxes on RRTMGP grid if (.not. allocated(rd%fsdn)) then allocate(rd%fsdn(pcols,nlay+1), rd%fsdnc(pcols,nlay+1), rd%fsup(pcols,nlay+1), rd%fsupc(pcols,nlay+1), & rd%fldn(pcols,nlay+1), rd%fldnc(pcols,nlay+1), rd%flup(pcols,nlay+1), rd%flupc(pcols,nlay+1) ) @@ -1289,7 +1285,6 @@ subroutine radiation_tend( & alb_dif, & ! output tsi & ! output, total solar irradiance (not scaled) ) - nlevrad = size(t_rad,2) !!--> Set TSI used in radiation to the value in the solar forcing file. !!--> This replaces get_variability() and does same thing. From f57e02726a0736902d2de7aeb6489f656a29effe Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 1 Sep 2023 19:58:06 -0400 Subject: [PATCH 13/53] cleanup solar forcing and gas_concs init; bugfix in rrtmgp_inputs --- src/physics/cam/aer_rad_props.F90 | 8 +- src/physics/cam/phys_prop.F90 | 11 +- src/physics/cam/rad_constituents.F90 | 4 +- src/physics/camrt/radconstants.F90 | 17 -- src/physics/rrtmg/cloud_rad_props.F90 | 2 +- src/physics/rrtmg/ebert_curry.F90 | 2 +- src/physics/rrtmg/oldcloud.F90 | 2 +- src/physics/rrtmg/radconstants.F90 | 16 -- src/physics/rrtmg/slingo.F90 | 2 +- src/physics/rrtmgp/cloud_rad_props.F90 | 2 +- src/physics/rrtmgp/ebert_curry.F90 | 15 +- src/physics/rrtmgp/oldcloud.F90 | 8 +- src/physics/rrtmgp/rad_solar_var.F90 | 145 ---------- src/physics/rrtmgp/radconstants.F90 | 350 ++++++++----------------- src/physics/rrtmgp/radiation.F90 | 249 +++++++----------- src/physics/rrtmgp/rrtmgp_inputs.F90 | 150 ++++------- src/physics/rrtmgp/slingo.F90 | 22 +- src/physics/simple/radconstants.F90 | 2 - 18 files changed, 262 insertions(+), 745 deletions(-) delete mode 100644 src/physics/rrtmgp/rad_solar_var.F90 diff --git a/src/physics/cam/aer_rad_props.F90 b/src/physics/cam/aer_rad_props.F90 index 058f53f784..be8f0708a6 100644 --- a/src/physics/cam/aer_rad_props.F90 +++ b/src/physics/cam/aer_rad_props.F90 @@ -11,7 +11,8 @@ module aer_rad_props use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc -use radconstants, only: nrh, nswbands, nlwbands, idx_sw_diag, ot_length +use radconstants, only: nswbands, nlwbands, idx_sw_diag +use phys_prop, only: nrh, ot_length use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, & rad_cnst_get_aer_props use wv_saturation, only: qsat @@ -304,9 +305,6 @@ end subroutine aer_rad_props_sw subroutine aer_rad_props_lw(list_idx, state, pbuf, odap_aer) - use radconstants, only: ot_length - - use physics_buffer, only : pbuf_get_field, pbuf_get_index, physics_buffer_desc ! Purpose: Compute aerosol transmissions needed in absorptivity/ ! emissivity calculations @@ -314,6 +312,8 @@ subroutine aer_rad_props_lw(list_idx, state, pbuf, odap_aer) ! species. If this changes, this routine will need to do something ! similar to the sw with routines like get_hygro_lw_abs + use physics_buffer, only : pbuf_get_field, pbuf_get_index, physics_buffer_desc + ! Arguments integer, intent(in) :: list_idx ! index of the climate or a diagnostic list type(physics_state), intent(in), target :: state diff --git a/src/physics/cam/phys_prop.F90 b/src/physics/cam/phys_prop.F90 index 568427e44e..ecbf6f85e0 100644 --- a/src/physics/cam/phys_prop.F90 +++ b/src/physics/cam/phys_prop.F90 @@ -11,7 +11,7 @@ module phys_prop use shr_kind_mod, only: r8 => shr_kind_r8 use spmd_utils, only: masterproc -use radconstants, only: nrh, nlwbands, nswbands, idx_sw_diag +use radconstants, only: nlwbands, nswbands, idx_sw_diag use ioFileMod, only: getfil use cam_pio_utils, only: cam_pio_openfile use pio, only: file_desc_t, var_desc_t, pio_get_var, pio_inq_varid, & @@ -26,6 +26,7 @@ module phys_prop save integer, parameter, public :: ot_length = 32 + public :: & physprop_accum_unique_files, &! Make a list of the unique set of files that contain properties ! This is an initialization step that must be done before calling physprop_init @@ -105,6 +106,10 @@ module phys_prop ! array. character(len=256), allocatable :: uniquefilenames(:) +! Number of evenly spaced intervals in rh used in this module and in the aer_rad_props module +! for calculations of aerosol hygroscopic growth. +integer, parameter, public :: nrh = 1000 + !================================================================================================ contains !================================================================================================ @@ -1106,6 +1111,8 @@ subroutine bulk_props_init(physprop, nc_id) type(var_desc_T) :: vid + ! ***N.B.*** RRTMGP hasn't set the value of idx_sw_diag when this routine is + ! called. The debug option will need to be modified for RRTMGP. logical :: debug = .true. character(len=*), parameter :: subname = 'bulk_props_init' @@ -1134,7 +1141,7 @@ subroutine bulk_props_init(physprop, nc_id) ierr = pio_get_var(nc_id, vid, physprop%num_to_mass_aer) ! Output select data to log file - if (debug .and. masterproc) then + if (debug .and. masterproc .and. idx_sw_diag > 0) then if (trim(physprop%aername) == 'SULFATE') then write(iulog, '(2x, a)') '_______ hygroscopic growth in visible band _______' call aer_optics_log_rh('SO4', physprop%sw_hygro_ext(:,idx_sw_diag), & diff --git a/src/physics/cam/rad_constituents.F90 b/src/physics/cam/rad_constituents.F90 index ced2c35cfa..42c978cc72 100644 --- a/src/physics/cam/rad_constituents.F90 +++ b/src/physics/cam/rad_constituents.F90 @@ -17,9 +17,9 @@ module rad_constituents use physics_types, only: physics_state use phys_control, only: use_simple_phys use constituents, only: cnst_get_ind -use radconstants, only: nradgas, rad_gas_index, ot_length +use radconstants, only: nradgas, rad_gas_index use phys_prop, only: physprop_accum_unique_files, physprop_init, & - physprop_get_id + physprop_get_id, ot_length use cam_history, only: addfld, fieldname_len, outfld, horiz_only use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_index diff --git a/src/physics/camrt/radconstants.F90 b/src/physics/camrt/radconstants.F90 index 89503fd0f5..c95c8d2154 100644 --- a/src/physics/camrt/radconstants.F90 +++ b/src/physics/camrt/radconstants.F90 @@ -21,9 +21,6 @@ module radconstants public :: radconstants_init public :: rad_gas_index -! optics files specify a type. What length is it? -integer, parameter, public :: ot_length = 32 - ! SHORTWAVE DATA ! number of shorwave spectral intervals @@ -40,20 +37,6 @@ module radconstants integer, parameter, public :: idx_lw_diag = 2 ! index to (H20 window) LW band - -! Number of evenly spaced intervals in rh -! The globality of this mesh may not be necessary -! Perhaps it could be specific to the aerosol -! But it is difficult to see how refined it must be -! for lookup. This value was found to be sufficient -! for Sulfate and probably necessary to resolve the -! high variation near rh = 1. Alternative methods -! were found to be too slow. -! Optimal approach would be for cam to specify size of aerosol -! based on each aerosol's characteristics. Radiation -! should know nothing about hygroscopic growth! -integer, parameter, public :: nrh = 1000 - ! LONGWAVE DATA ! number of lw bands diff --git a/src/physics/rrtmg/cloud_rad_props.F90 b/src/physics/rrtmg/cloud_rad_props.F90 index 2911e0ac21..c629c38e4b 100644 --- a/src/physics/rrtmg/cloud_rad_props.F90 +++ b/src/physics/rrtmg/cloud_rad_props.F90 @@ -7,7 +7,7 @@ module cloud_rad_props use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx -use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag +use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_lw_diag use cam_abortutils, only: endrun use rad_constituents, only: iceopticsfile, liqopticsfile use oldcloud, only: oldcloud_lw, old_liq_get_rad_props_lw, old_ice_get_rad_props_lw, oldcloud_init diff --git a/src/physics/rrtmg/ebert_curry.F90 b/src/physics/rrtmg/ebert_curry.F90 index a1e1c031b1..7bca4ce257 100644 --- a/src/physics/rrtmg/ebert_curry.F90 +++ b/src/physics/rrtmg/ebert_curry.F90 @@ -7,7 +7,7 @@ module ebert_curry use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx -use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag, get_sw_spectral_boundaries +use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_lw_diag, get_sw_spectral_boundaries use cam_abortutils, only: endrun use cam_history, only: outfld diff --git a/src/physics/rrtmg/oldcloud.F90 b/src/physics/rrtmg/oldcloud.F90 index 609c6b4668..fb0ae4d80e 100644 --- a/src/physics/rrtmg/oldcloud.F90 +++ b/src/physics/rrtmg/oldcloud.F90 @@ -7,7 +7,7 @@ module oldcloud use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field -use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag, get_sw_spectral_boundaries +use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_lw_diag, get_sw_spectral_boundaries use cam_abortutils, only: endrun use cam_history, only: outfld use rad_constituents, only: iceopticsfile, liqopticsfile diff --git a/src/physics/rrtmg/radconstants.F90 b/src/physics/rrtmg/radconstants.F90 index f4f8c76b9c..601bcd3cf6 100644 --- a/src/physics/rrtmg/radconstants.F90 +++ b/src/physics/rrtmg/radconstants.F90 @@ -63,19 +63,6 @@ module radconstants integer, parameter, public :: rrtmg_sw_cloudsim_band = 9 ! rrtmg band for .67 micron -! Number of evenly spaced intervals in rh -! The globality of this mesh may not be necessary -! Perhaps it could be specific to the aerosol -! But it is difficult to see how refined it must be -! for lookup. This value was found to be sufficient -! for Sulfate and probably necessary to resolve the -! high variation near rh = 1. Alternative methods -! were found to be too slow. -! Optimal approach would be for cam to specify size of aerosol -! based on each aerosol's characteristics. Radiation -! should know nothing about hygroscopic growth! -integer, parameter, public :: nrh = 1000 - ! LONGWAVE DATA ! These are indices to the band for diagnostic output @@ -123,9 +110,6 @@ module radconstants real(r8), public, parameter :: minmmr(nradgas) & = epsilon(1._r8) -! Length of "optics type" string specified in optics files. -integer, parameter, public :: ot_length = 32 - public :: rad_gas_index public :: get_number_sw_bands, & diff --git a/src/physics/rrtmg/slingo.F90 b/src/physics/rrtmg/slingo.F90 index aedb44bcee..b9d68565ec 100644 --- a/src/physics/rrtmg/slingo.F90 +++ b/src/physics/rrtmg/slingo.F90 @@ -9,7 +9,7 @@ module slingo use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx -use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag, get_sw_spectral_boundaries +use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_lw_diag, get_sw_spectral_boundaries use cam_abortutils, only: endrun use cam_history, only: outfld diff --git a/src/physics/rrtmgp/cloud_rad_props.F90 b/src/physics/rrtmgp/cloud_rad_props.F90 index 1099fb714a..1581e04d9a 100644 --- a/src/physics/rrtmgp/cloud_rad_props.F90 +++ b/src/physics/rrtmgp/cloud_rad_props.F90 @@ -7,7 +7,7 @@ module cloud_rad_props use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx -use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag +use radconstants, only: nswbands, nlwbands, idx_sw_diag use cam_abortutils, only: endrun use rad_constituents, only: iceopticsfile, liqopticsfile use oldcloud, only: oldcloud_lw, old_liq_get_rad_props_lw, old_ice_get_rad_props_lw, oldcloud_init diff --git a/src/physics/rrtmgp/ebert_curry.F90 b/src/physics/rrtmgp/ebert_curry.F90 index a1e1c031b1..c04a864ef0 100644 --- a/src/physics/rrtmgp/ebert_curry.F90 +++ b/src/physics/rrtmgp/ebert_curry.F90 @@ -7,7 +7,7 @@ module ebert_curry use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx -use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag, get_sw_spectral_boundaries +use radconstants, only: nswbands, nlwbands, get_sw_spectral_boundaries use cam_abortutils, only: endrun use cam_history, only: outfld @@ -143,10 +143,7 @@ subroutine cloud_rad_props_get_sw(state, pbuf, & tau_w_g(:,1:ncol,:) = 0._r8 tau_w_f(:,1:ncol,:) = 0._r8 - call ec_ice_optics_sw (state, pbuf, tau, tau_w, tau_w_g, tau_w_f, oldicewp=.true.) -! call outfld ('CI_OD_SW_OLD', ice_tau(idx_sw_diag,:,:), pcols, lchnk) - end subroutine cloud_rad_props_get_sw !============================================================================== @@ -182,7 +179,6 @@ subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldl cld_abs_od = 0._r8 call ec_ice_get_rad_props_lw(state, pbuf, cld_abs_od, oldicewp=.true.) - !call outfld('CI_OD_LW_OLD', ice_tau_abs_od(idx_lw_diag ,:,:), pcols, lchnk) end subroutine cloud_rad_props_get_lw @@ -390,18 +386,11 @@ subroutine ec_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp) 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 - !if(oldicewp) then - ! call outfld('CIWPTH_OLD',cicewp(:,:)/1000,pcols,lchnk) - !else - ! call outfld('CIWPTH_OLD',iciwpth(:,:),pcols,lchnk) - !endif - !call outfld('CI_OD_LW_OLD',cldtau(:,:),pcols,lchnk) - end subroutine ec_ice_get_rad_props_lw !============================================================================== diff --git a/src/physics/rrtmgp/oldcloud.F90 b/src/physics/rrtmgp/oldcloud.F90 index 609c6b4668..06a91b232e 100644 --- a/src/physics/rrtmgp/oldcloud.F90 +++ b/src/physics/rrtmgp/oldcloud.F90 @@ -7,7 +7,7 @@ module oldcloud use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field -use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag, get_sw_spectral_boundaries +use radconstants, only: nswbands, nlwbands, get_sw_spectral_boundaries use cam_abortutils, only: endrun use cam_history, only: outfld use rad_constituents, only: iceopticsfile, liqopticsfile @@ -226,12 +226,6 @@ subroutine old_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, li end do ! End do k=1,pver end do ! nswbands - !call outfld('CL_OD_SW_OLD',liq_tau(idx_sw_diag,:,:), pcols, lchnk) - !call outfld('REL_OLD',rel(:,:), pcols, lchnk) - !call outfld('CLWPTH_OLD',cliqwp(:,:), pcols, lchnk) - !call outfld('KEXT_OLD',kext(:,:), pcols, lchnk) - - end subroutine old_liquid_optics_sw !============================================================================== diff --git a/src/physics/rrtmgp/rad_solar_var.F90 b/src/physics/rrtmgp/rad_solar_var.F90 deleted file mode 100644 index 0cf996e901..0000000000 --- a/src/physics/rrtmgp/rad_solar_var.F90 +++ /dev/null @@ -1,145 +0,0 @@ -!------------------------------------------------------------------------------- -! This module uses the Lean solar irradiance data to provide a solar cycle -! scaling factor used in heating rate calculations -!------------------------------------------------------------------------------- -module rad_solar_var - - use radconstants, only : nswbands - use shr_kind_mod , only : r8 => shr_kind_r8 - use solar_irrad_data, only : sol_irrad, we, nbins, has_spectrum, sol_tsi - use solar_irrad_data, only : do_spctrl_scaling - use cam_abortutils, only : endrun - - implicit none - save - - private - public :: rad_solar_var_init - public :: get_variability - - real(r8), allocatable :: ref_band_irrad(:) ! scaling will be relative to ref_band_irrad in each band - real(r8), allocatable :: irrad(:) ! solar irradiance at model timestep in each band - real(r8) :: tsi_ref ! total solar irradiance assumed by RRTMGP - - real(r8), allocatable :: radbinmax(:) - real(r8), allocatable :: radbinmin(:) - -!------------------------------------------------------------------------------- -contains -!------------------------------------------------------------------------------- - - subroutine rad_solar_var_init( ) - use radconstants, only : get_sw_spectral_boundaries - use radconstants, only : get_ref_solar_band_irrad - use radconstants, only : get_ref_total_solar_irrad - - integer :: i - integer :: ierr - integer :: yr, mon, tod - integer :: radmax_loc - - - if ( do_spctrl_scaling ) then - - if ( .not.has_spectrum ) then - call endrun('rad_solar_var_init: solar input file must have irradiance spectrum') - endif - - allocate (radbinmax(nswbands),stat=ierr) - if (ierr /= 0) then - call endrun('rad_solar_var_init: Error allocating space for radbinmax') - end if - - allocate (radbinmin(nswbands),stat=ierr) - if (ierr /= 0) then - call endrun('rad_solar_var_init: Error allocating space for radbinmin') - end if - - allocate (ref_band_irrad(nswbands), stat=ierr) - if (ierr /= 0) then - call endrun('rad_solar_var_init: Error allocating space for ref_band_irrad') - end if - - allocate (irrad(nswbands), stat=ierr) - if (ierr /= 0) then - call endrun('rad_solar_var_init: Error allocating space for irrad') - end if - - call get_sw_spectral_boundaries(radbinmin, radbinmax, 'nm') - - ! Make sure that the far-IR is included, even if RRTMG does not - ! extend that far down. 10^5 nm corresponds to a wavenumber of - ! 100 cm^-1. - radmax_loc = maxloc(radbinmax,1) - radbinmax(radmax_loc) = max(100000._r8,radbinmax(radmax_loc)) - - ! for rrtmg, reference spectrum from rrtmg - call get_ref_solar_band_irrad( ref_band_irrad ) - - else - - call get_ref_total_solar_irrad(tsi_ref) - - endif - - end subroutine rad_solar_var_init - -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------------- - subroutine get_variability( sfac ) - - real(r8), intent(out) :: sfac(nswbands) ! scaling factors for CAM heating - - integer :: yr, mon, day, tod - - if ( do_spctrl_scaling ) then - call integrate_spectrum( nbins, nswbands, we, radbinmin, radbinmax, sol_irrad, irrad) - sfac(:nswbands) = irrad(:nswbands)/ref_band_irrad(:nswbands) - else - sfac(:nswbands) = sol_tsi/tsi_ref - endif - - end subroutine get_variability - -!------------------------------------------------------------------------------- -! private method......... -!------------------------------------------------------------------------------- - - subroutine integrate_spectrum( nsrc, ntrg, src_x, min_trg, max_trg, src, trg ) - - use mo_util, only : rebin - - implicit none - - !--------------------------------------------------------------- - ! ... dummy arguments - !--------------------------------------------------------------- - integer, intent(in) :: nsrc ! dimension source array - integer, intent(in) :: ntrg ! dimension target array - real(r8), intent(in) :: src_x(nsrc+1) ! source coordinates - real(r8), intent(in) :: max_trg(ntrg) ! target coordinates - real(r8), intent(in) :: min_trg(ntrg) ! target coordinates - real(r8), intent(in) :: src(nsrc) ! source array - real(r8), intent(out) :: trg(ntrg) ! target array - - !--------------------------------------------------------------- - ! ... local variables - !--------------------------------------------------------------- - real(r8) :: trg_x(2), targ(1) ! target coordinates - integer :: i - - do i = 1, ntrg - - trg_x(1) = min_trg(i) - trg_x(2) = max_trg(i) - - call rebin( nsrc, 1, src_x, trg_x, src(1:nsrc), targ(:) ) - ! W/m2/nm --> W/m2 - trg( i ) = targ(1)*(trg_x(2)-trg_x(1)) - - enddo - - - end subroutine integrate_spectrum - -end module rad_solar_var diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index e573bfb792..d086d1ce16 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -3,16 +3,6 @@ module radconstants ! This module contains constants that are specific to the radiative transfer ! code used in the RRTMGP model. -! This comment from E3SM implementation, and is entirely relevant here: -! TODO: Should this data be handled in a more robust way? Much of this contains -! explicit mappings to indices, which would probably be better handled with get_ -! functions. I.e., get_nswbands() could query the kdist objects in case of -! RRTMGP, and the diag indices could look up the actual bands used in the kdist -! objects as well. On that note, this module should probably go away if -! possible in the future, and we should provide more robust access to the -! radiation interface. - - use shr_kind_mod, only: r8 => shr_kind_r8 use cam_abortutils, only: endrun @@ -20,228 +10,93 @@ module radconstants private save -! Number of bands in SW and LW (these will be checked when RRTMGP initializes) +! 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. integer, parameter, public :: nswbands = 14 integer, parameter, public :: nlwbands = 16 -! Band limits (these get also get set at initialization) -real(r8), public, allocatable :: wavenumber_low_shortwave(:) -real(r8), public, allocatable :: wavenumber_high_shortwave(:) -real(r8), public, allocatable :: wavenumber_low_longwave(:) -real(r8), public, allocatable :: wavenumber_high_longwave(:) -! Reference irradiance per band -real(r8), public, allocatable :: solar_ref_band_irradiance(:) -real(r8), public, protected :: ref_tsi - -! SHORTWAVE DATA - - -! Wavenumbers of band boundaries -! -! Note: Currently rad_solar_var extends the lowest band down to -! 100 cm^-1 if it is too high to cover the far-IR. Any changes meant -! to affect IR solar variability should take note of this. - -! NOTE: these follow the non-monotonic ordering used for RRTMG -! - This is necessary because the optical properties files made for RRTMG use this order too. - -! NOTE: aside from order, as noted, these values match the ones in -! RRTMGP coefficients files. But I think we should be *setting* these -! values based on what is in that file, rather than hard-coding it here. - -! BPM: comment this data structure --> set it from radiation_init -! real(r8),parameter :: wavenumber_low_shortwave(nswbands) = & ! in cm^-1 -! (/2600._r8, 3250._r8, 4000._r8, 4650._r8, 5150._r8, 6150._r8, 7700._r8, & -! 8050._r8,12850._r8,16000._r8,22650._r8,29000._r8,38000._r8, 820._r8/) -! real(r8),parameter :: wavenumber_high_shortwave(nswbands) = & ! in cm^-1 -! (/3250._r8, 4000._r8, 4650._r8, 5150._r8, 6150._r8, 7700._r8, 8050._r8, & -! 12850._r8,16000._r8,22650._r8,29000._r8,38000._r8,50000._r8, 2600._r8/) - -! Mapping from RRTMG shortwave bands to RRTMGP -integer, parameter, dimension(14), public :: rrtmg_to_rrtmgp_swbands = & - (/ & - 14, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13 & - /) - -! BPM <-- commented this block. Replaced by allocatable, get values by calling set_irrad_by_band --> -! Solar irradiance at 1 A.U. in W/m^2 assumed by radiation code -! Rescaled so that sum is precisely 1368.22 and fractional amounts sum to 1.0 -! real(r8), parameter :: solar_ref_band_irradiance(nswbands) = & -! (/ & -! 12.11_r8, 20.3600000000001_r8, 23.73_r8, & -! 22.43_r8, 55.63_r8, 102.93_r8, 24.29_r8, & -! 345.74_r8, 218.19_r8, 347.20_r8, & -! 129.49_r8, 50.15_r8, 3.08_r8, 12.89_r8 & -! /) - -! These are indices to the band for diagnostic output -! CHANGE: rather than make these parameters, provide subroutines that set them -! using the function get_band_index_by_value (which should be called on initializing radiation) -! integer, parameter, public :: idx_sw_diag = 10 ! index to sw visible band (441 - 625 nm) -! integer, parameter, public :: idx_nir_diag = 8 ! index to sw near infrared (778-1240 nm) band -! integer, parameter, public :: idx_uv_diag = 11 ! index to sw uv (345-441 nm) band - -! integer, parameter, public :: rrtmg_sw_cloudsim_band = 9 ! rrtmgp band for .67 micron -! integer, parameter, public :: rrtmgp_sw_cloudsim_band = 10 ! b/c one band moves to beginning - -integer, public :: idx_sw_diag ! index to sw visible band (441 - 625 nm) -integer, public :: idx_nir_diag! index to sw near infrared (778-1240 nm) band -integer, public :: idx_uv_diag ! index to sw uv (345-441 nm) band - -! CHANGE: instead of setting rrtmg[p]_sw_cloudsim_band in radconstants, just make it in radiation -! rrtmgp_sw_cloudsim_band = get_band_index_by_value('sw', 0.67_r8, 'micron') ! rrtmgp band for .67 micron -! same for lw: -! rrtmgp_lw_cloudsim_band = get_band_index_by_value('lw', 10.5_r8, 'micron') - -! Number of evenly spaced intervals in rh -! The globality of this mesh may not be necessary -! Perhaps it could be specific to the aerosol -! But it is difficult to see how refined it must be -! for lookup. This value was found to be sufficient -! for Sulfate and probably necessary to resolve the -! high variation near rh = 1. Alternative methods -! were found to be too slow. -! Optimal approach would be for cam to specify size of aerosol -! based on each aerosol's characteristics. Radiation -! should know nothing about hygroscopic growth! -integer, parameter, public :: nrh = 1000 - -! LONGWAVE DATA - -! These are indices to the band for diagnostic output (see comment above about change) -! integer, parameter, public :: idx_lw_diag = 7 ! index to (H20 window) LW band -integer, public :: idx_lw_diag - - -! These are commented, and intended to be replaced by reading the RRTMGP optics object -! real(r8), parameter :: wavenumber_low_longwave(nlwbands) = &! Longwave spectral band limits (cm-1) -! (/ 10._r8, 350._r8, 500._r8, 630._r8, 700._r8, 820._r8, 980._r8, 1080._r8, & -! 1180._r8, 1390._r8, 1480._r8, 1800._r8, 2080._r8, 2250._r8, 2380._r8, 2600._r8 /) - -! real(r8), parameter :: wavenumber_high_longwave(nlwbands) = &! Longwave spectral band limits (cm-1) -! (/ 350._r8, 500._r8, 630._r8, 700._r8, 820._r8, 980._r8, 1080._r8, 1180._r8, & -! 1390._r8, 1480._r8, 1800._r8, 2080._r8, 2250._r8, 2380._r8, 2600._r8, 3250._r8 /) +! Band limits (set from data in RRTMGP coefficient datasets) +real(r8), allocatable, target :: wavenumber_low_shortwave(:) +real(r8), allocatable, target :: wavenumber_high_shortwave(:) +real(r8), allocatable, target :: wavenumber_low_longwave(:) +real(r8), allocatable, target :: wavenumber_high_longwave(:) + +! These are indices to specific bands for diagnostic output and COSP input. +integer, public, protected :: idx_sw_diag = -1 ! band contains 500-nm wave +integer, public, protected :: idx_nir_diag = -1 ! band contains 1000-nm wave +integer, public, protected :: idx_uv_diag = -1 ! band contains 400-nm wave +integer, public, protected :: idx_lw_diag = -1 ! band contains 1000 cm-1 wave (H20 window) +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) +! 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 can +! be used to initialize the ty_gas_conc object because the name matching is case +! insensitive. integer, public, parameter :: gasnamelength = 5 integer, public, parameter :: nradgas = 8 character(len=gasnamelength), public, parameter :: gaslist(nradgas) & = (/'H2O ','O3 ', 'O2 ', 'CO2 ', 'N2O ', 'CH4 ', 'CFC11', 'CFC12'/) ! what is the minimum mass mixing ratio that can be supported by radiation implementation? -real(r8), public, parameter :: minmmr(nradgas) & - = epsilon(1._r8) - -! Length of "optics type" string specified in optics files. -integer, parameter, public :: ot_length = 32 - -public :: rad_gas_index - -public :: get_sw_spectral_boundaries, & - get_lw_spectral_boundaries, & - get_ref_solar_band_irrad, & - get_ref_total_solar_irrad, & - get_idx_sw_diag, & - get_idx_nir_diag, & - get_idx_uv_diag, & - get_idx_lw_diag, & - get_band_index_by_value, & - set_wavenumber_bands,& - set_irrad_by_band, & - set_reference_tsi +real(r8), public, parameter :: minmmr(nradgas) = epsilon(1._r8) + +public :: & + set_wavenumber_bands, & + get_sw_spectral_boundaries, & + get_lw_spectral_boundaries, & + get_band_index_by_value, & + rad_gas_index !=============================================================================== contains !=============================================================================== -subroutine get_ref_total_solar_irrad(tsi) - ! provide Total Solar Irradiance assumed by RRTMGP - - real(r8), intent(out) :: tsi - - ! tsi = sum(solar_ref_band_irradiance) - tsi = ref_tsi - -end subroutine get_ref_total_solar_irrad -!------------------------------------------------------------------------------ -subroutine set_reference_tsi(tsi) - ! set ref_tsi to provide total solar irradiance - ! this usually comes from reading a file - ! provided by the radiation scheme developers - real(r8), intent(in) :: tsi - ref_tsi = tsi -end subroutine set_reference_tsi -!------------------------------------------------------------------------------ -subroutine get_ref_solar_band_irrad( band_irrad ) - ! note: this shouldn't be used. - ! Instead, just use radconstants, only: solar_ref_band_irradiance - ! to access the data directly - ! solar irradiance in each band (W/m^2) - real(r8), intent(out) :: band_irrad(nswbands) - - if (allocated(solar_ref_band_irradiance)) then - band_irrad = solar_ref_band_irradiance - else - ! what to do - end if +subroutine set_wavenumber_bands(swlw, nbands, values) -end subroutine get_ref_solar_band_irrad + ! Set the low and high limits of the wavenumber grid for sw or lw. + ! Values comes from RRTMGP coefficients datasets. + ! Also set band indices for bands containing specific wavelengths. -!------------------------------------------------------------------------------ + character(*), intent(in) :: swlw ! which bands to set ['sw', 'lw'] + integer, intent(in) :: nbands + real(r8), intent(in) :: values(2,nbands) ! cm-1 -subroutine set_wavenumber_bands(swlw, nbands, values) - ! set the low and high limits of the wavenumber grid for sw or lw - ! expect that values comes from RRTMGP method get_band_lims_wavenumber - character(*), intent(in) :: swlw ! which set of bands to set ['sw', 'lw'] - integer, intent(in) :: nbands - real(r8), intent(in) :: values(2,nbands) select case(swlw) case ('sw') allocate(wavenumber_low_shortwave(nbands)) allocate(wavenumber_high_shortwave(nbands)) wavenumber_low_shortwave = values(1,:) wavenumber_high_shortwave = values(2,:) + + idx_sw_diag = get_band_index_by_value('sw', 500.0_r8, 'nm') + idx_nir_diag = get_band_index_by_value('sw', 1000.0_r8, 'nm') + idx_uv_diag = get_band_index_by_value('sw', 400._r8, 'nm') + idx_sw_cloudsim = get_band_index_by_value('sw', 0.67_r8, 'micron') + case ('lw') allocate(wavenumber_low_longwave(nbands)) allocate(wavenumber_high_longwave(nbands)) wavenumber_low_longwave = values(1,:) wavenumber_high_longwave = values(2,:) - end select -end subroutine set_wavenumber_bands -!------------------------------------------------------------------------------ -subroutine get_lw_spectral_boundaries(low_boundaries, high_boundaries, units) - ! provide spectral boundaries of each longwave band - real(r8), intent(out) :: low_boundaries(nlwbands), high_boundaries(nlwbands) - character(*), intent(in) :: units ! requested units + idx_lw_diag = get_band_index_by_value('lw', 1000.0_r8, 'cm^-1') + idx_lw_cloudsim = get_band_index_by_value('lw', 10.5_r8, 'micron') - select case (units) - case ('inv_cm','cm^-1','cm-1') - low_boundaries = wavenumber_low_longwave - high_boundaries = wavenumber_high_longwave - case('m','meter','meters') - low_boundaries = 1.e-2_r8/wavenumber_high_longwave - high_boundaries = 1.e-2_r8/wavenumber_low_longwave - case('nm','nanometer','nanometers') - low_boundaries = 1.e7_r8/wavenumber_high_longwave - high_boundaries = 1.e7_r8/wavenumber_low_longwave - case('um','micrometer','micrometers','micron','microns') - low_boundaries = 1.e4_r8/wavenumber_high_longwave - high_boundaries = 1.e4_r8/wavenumber_low_longwave - case('cm','centimeter','centimeters') - low_boundaries = 1._r8/wavenumber_high_longwave - high_boundaries = 1._r8/wavenumber_low_longwave - case default - call endrun('get_lw_spectral_boundaries: spectral units not acceptable'//units) end select -end subroutine get_lw_spectral_boundaries +end subroutine set_wavenumber_bands !------------------------------------------------------------------------------ + subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) + ! provide spectral boundaries of each shortwave band - real(r8), intent(out) :: low_boundaries(nswbands), high_boundaries(nswbands) + real(r8), intent(out) :: low_boundaries(nswbands), high_boundaries(nswbands) character(*), intent(in) :: units ! requested units select case (units) @@ -261,12 +116,44 @@ subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) low_boundaries = 1._r8/wavenumber_high_shortwave high_boundaries = 1._r8/wavenumber_low_shortwave case default - call endrun('rad_constants.F90: requested spectral units not acceptable: '//units) + call endrun('rad_constants.F90: requested spectral units not recognized: '//units) end select end subroutine get_sw_spectral_boundaries !------------------------------------------------------------------------------ + +subroutine get_lw_spectral_boundaries(low_boundaries, high_boundaries, units) + + ! provide spectral boundaries of each longwave band + + real(r8), intent(out) :: low_boundaries(nlwbands), high_boundaries(nlwbands) + character(*), intent(in) :: units ! requested units + + select case (units) + case ('inv_cm','cm^-1','cm-1') + low_boundaries = wavenumber_low_longwave + high_boundaries = wavenumber_high_longwave + case('m','meter','meters') + low_boundaries = 1.e-2_r8/wavenumber_high_longwave + high_boundaries = 1.e-2_r8/wavenumber_low_longwave + case('nm','nanometer','nanometers') + low_boundaries = 1.e7_r8/wavenumber_high_longwave + high_boundaries = 1.e7_r8/wavenumber_low_longwave + case('um','micrometer','micrometers','micron','microns') + low_boundaries = 1.e4_r8/wavenumber_high_longwave + high_boundaries = 1.e4_r8/wavenumber_low_longwave + case('cm','centimeter','centimeters') + low_boundaries = 1._r8/wavenumber_high_longwave + high_boundaries = 1._r8/wavenumber_low_longwave + case default + call endrun('get_lw_spectral_boundaries: spectral units not recognized: '//units) + end select + +end subroutine get_lw_spectral_boundaries + +!------------------------------------------------------------------------------ + integer function rad_gas_index(gasname) ! return the index in the gaslist array of the specified gasname @@ -283,48 +170,36 @@ integer function rad_gas_index(gasname) enddo call endrun ("rad_gas_index: can not find gas with name "//gasname) end function rad_gas_index -!------------------------------------------------------------------------------ -subroutine get_idx_sw_diag() - idx_sw_diag = get_band_index_by_value('sw', 500.0_r8, 'nm') -end subroutine -subroutine get_idx_nir_diag() - idx_nir_diag = get_band_index_by_value('sw', 1000.0_r8, 'nm') -end subroutine +!------------------------------------------------------------------------------ -subroutine get_idx_uv_diag() - idx_uv_diag = get_band_index_by_value('sw', 400._r8, 'nm') -end subroutine +function get_band_index_by_value(swlw, targetvalue, units) result(ans) -subroutine get_idx_lw_diag() - idx_lw_diag = get_band_index_by_value('lw', 1000.0_r8, 'cm^-1') - ! value chosen to match the band used in CESM1/CESM2 -end subroutine + ! Find band index for requested wavelength/wavenumber. -function get_band_index_by_value(swlw, targetvalue, units) result(ans) - character(len=*),intent(in) :: swlw ! sw or lw bands - real(r8),intent(in) :: targetvalue - character(len=*),intent(in) :: units ! units of targetvalue + character(len=*), intent(in) :: swlw ! sw or lw bands + real(r8), intent(in) :: targetvalue + character(len=*), intent(in) :: units ! units of targetvalue integer :: ans + ! local - real(r8), allocatable, dimension(:) :: lowboundaries, highboundaries + real(r8), pointer, dimension(:) :: lowboundaries, highboundaries real(r8) :: tgt integer :: nbnds, i select case (swlw) case ('sw','SW','shortwave') nbnds = nswbands - allocate(lowboundaries(nbnds), highboundaries(nbnds)) - lowboundaries = wavenumber_low_shortwave - highboundaries = wavenumber_high_shortwave + lowboundaries => wavenumber_low_shortwave + highboundaries => wavenumber_high_shortwave case ('lw', 'LW', 'longwave') nbnds = nlwbands - allocate(lowboundaries(nbnds), highboundaries(nbnds)) - lowboundaries = wavenumber_low_longwave - highboundaries = wavenumber_high_longwave + lowboundaries => wavenumber_low_longwave + highboundaries => wavenumber_high_longwave case default - call endrun('rad_constants.F90: get_band_index_by_value: type of bands not accepted '//swlw) + call endrun('radconstants.F90: get_band_index_by_value: type of bands not recognized: '//swlw) end select + ! band info is in cm^-1 but target value may be other units, ! so convert targetvalue to cm^-1 select case (units) @@ -339,43 +214,24 @@ function get_band_index_by_value(swlw, targetvalue, units) result(ans) case('cm','centimeter','centimeters') tgt = 1._r8/targetvalue case default - call endrun('rad_constants.F90: get_band_index_by_value: units not acceptable'//units) + call endrun('radconstants.F90: get_band_index_by_value: units not recognized: '//units) end select + ! now just loop through the array + ans = 0 do i = 1,nbnds if ((tgt > lowboundaries(i)) .and. (tgt <= highboundaries(i))) then ans = i exit end if end do - ! Do something if the answer is not found? -end function get_band_index_by_value - -subroutine set_irrad_by_band(solar_source, g2b) - ! Sets the solar irradiance in each shortwave band by summing the irradiance from gpoints. - ! solar_source = kdist_sw%solar_source <-- private TRY solar_source = kdist_sw%solar_source_quiet - ! g2b = kdist_sw%get_gpoint_bands() - real(r8), intent(in) :: solar_source(:) ! size ngpoints: irradiance per gpoint - integer, intent(in) :: g2b(:) ! size ngpoints: mapping from gpoint to band - integer :: i - allocate(solar_ref_band_irradiance(nswbands)) - solar_ref_band_irradiance(:) = 0.0_r8 - do i = 1,size(g2b) - solar_ref_band_irradiance(g2b(i)) = solar_ref_band_irradiance(g2b(i)) + solar_source(i) - end do -end subroutine set_irrad_by_band - -function get_irrad_by_band(solar_source, g2b) result(ans) - real(r8) :: solar_source(:) - integer :: g2b(:) - real(r8), allocatable :: ans(:) - if (.not. allocated(solar_ref_band_irradiance)) then - call set_irrad_by_band(solar_source, g2b) + if (ans == 0) then + call endrun('radconstants.F90: get_band_index_by_value: band not found: ') end if - allocate(ans(size(solar_ref_band_irradiance))) - ans = solar_ref_band_irradiance -end function get_irrad_by_band + +end function get_band_index_by_value +!------------------------------------------------------------------------------ end module radconstants diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index baf9620389..12955ae4ed 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -15,6 +15,7 @@ module radiation use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx use camsrfexch, only: cam_out_t, cam_in_t use physconst, only: cappa, cpair, gravit +use solar_irrad_data, only: sol_tsi use time_manager, only: get_nstep, is_first_restart_step, & get_curr_calday, get_step_size @@ -27,20 +28,9 @@ module radiation liqcldoptics, & icecldoptics -use radconstants, only: nswbands, nlwbands, & ! number of bands - idx_sw_diag, & ! indices for diagnostics - idx_nir_diag, & - idx_uv_diag, & - idx_lw_diag, & - get_idx_sw_diag, & ! sets the idx_*_diag in radconstants module - get_idx_nir_diag, & - get_idx_uv_diag, & - get_idx_lw_diag, & - rrtmg_to_rrtmgp_swbands, & ! maps bands between rrtmg and rrtmgp - get_band_index_by_value, & ! function that figures out band for a wavelength - gasnamelength, & - nradgas, & - gaslist +use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_nir_diag, idx_uv_diag, & + idx_lw_diag, idx_sw_cloudsim, idx_lw_cloudsim, & + nradgas, gasnamelength, gaslist use mo_gas_concentrations, only: ty_gas_concs use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp @@ -67,14 +57,16 @@ module radiation PIO_NOWRITE, & pio_closefile -use cam_abortutils, only: endrun -use error_messages, only: handle_err -use cam_logfile, only: iulog use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & cospsimulator_intr_run, cosp_nradsteps +use string_utils, only: to_lower +use cam_abortutils, only: endrun +use error_messages, only: handle_err +use cam_logfile, only: iulog + implicit none private @@ -94,7 +86,6 @@ module radiation integer,public, allocatable :: cosp_cnt(:) ! counter for cosp integer,public :: cosp_cnt_init = 0 !initial value for cosp counter -integer, public :: sw_cloudsim_band, lw_cloudsim_band ! radiation bands that COSP uses real(r8), public, protected :: nextsw_cday ! future radiation calday for surface models @@ -181,6 +172,10 @@ module radiation logical :: graupel_in_rad = .false. ! graupel in radiation code logical :: use_rad_uniform_angle = .false. ! if true, use the namelist rad_uniform_angle for the coszrs calculation +! active_calls is set by a rad_constituents method after parsing namelist input +! for the rad_climate and rad_diag_N entries. +logical :: active_calls(0:N_DIAG) + ! Physics buffer indices integer :: qrs_idx = 0 integer :: qrl_idx = 0 @@ -222,29 +217,22 @@ module radiation ! vertical coordinate for output of fluxes on radiation grid real(r8), allocatable, target :: plev_rad(:) -! LW coefficients -type(ty_gas_optics_rrtmgp) :: kdist_lw ! bpm changed here - -! SW coefficients -type(ty_gas_optics_rrtmgp) :: kdist_sw ! bpm changed here -integer :: ngpt_sw +! Gas optics objects contain the data read from the coefficients files. +type(ty_gas_optics_rrtmgp) :: kdist_lw +type(ty_gas_optics_rrtmgp) :: kdist_sw -! data to go from bands to gpoints (bpm) -integer, allocatable :: band2gpt_sw(:,:) ! n[s,l]wbands come from radconstants for now +! data to go from bands to gpoints +integer, allocatable :: band2gpt_sw(:,:) integer, allocatable :: band2gpt_lw(:,:) +! Mapping from RRTMG shortwave bands to RRTMGP. Currently needed to continue using +! the SW optics datasets from RRTMG (even thought there is a slight mismatch in the +! band boundaries of the 2 bands that overlap with the LW bands). +integer, parameter, dimension(14) :: rrtmg_to_rrtmgp_swbands = & + [ 14, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13 ] -! Gases to use in the radiative calculations. -! RRTMGP kdist initialization needs to know the names of the -! gases before these are available via the rad_cnst interface. -! TODO: Move this to namelist or somewhere appropriate. -! NOTE: This list is not the same as `gaslist` in radconstants; is that a problem? Implication for diagnostic calls? -! character(len=5), dimension(10) :: active_gases = (/ & -! 'H2O ', 'CO2 ', 'O3 ', 'N2O ', & -! 'CO ', 'CH4 ', 'O2 ', 'N2 ', & -! 'CFC11', 'CFC12' /) -! BPM: use radconstants to define the active gases: -character(len=gasnamelength), dimension(nradgas) :: active_gases = gaslist +! lower case version of gaslist for RRTMGP +character(len=gasnamelength) :: gaslist_lc(nradgas) type(var_desc_t) :: cospcnt_desc ! cosp type(var_desc_t) :: nextsw_cday_desc @@ -474,13 +462,12 @@ subroutine radiation_init(pbuf2d) use physics_buffer, only: pbuf_get_index, pbuf_set_field use phys_control, only: phys_getopts - use rad_solar_var, only: rad_solar_var_init ! This initializes total solar irradiance use radiation_data, only: rad_data_init use cloud_rad_props, only: cloud_rad_props_init use modal_aer_opt, only: modal_aer_opt_init use rrtmgp_inputs, only: rrtmgp_inputs_init use time_manager, only: is_first_step - use radconstants, only: set_wavenumber_bands, set_irrad_by_band, set_reference_tsi + use radconstants, only: set_wavenumber_bands ! arguments type(physics_buffer_desc), pointer :: pbuf2d(:,:) @@ -492,8 +479,7 @@ subroutine radiation_init(pbuf2d) ! -- needed for the kdist initialization routines type(ty_gas_concs) :: available_gases - integer :: icall, nmodes - logical :: active_calls(0:N_DIAG) + integer :: i, icall, nmodes integer :: nstep ! current timestep number logical :: history_amwg ! output the variables used by the AMWG diag package logical :: history_vdiag ! output the variables used by the AMWG variability diag package @@ -504,7 +490,6 @@ subroutine radiation_init(pbuf2d) integer :: ierr integer :: dtime - real(r8) :: ref_tsi character(len=*), parameter :: sub = 'radiation_init' !----------------------------------------------------------------------- @@ -538,11 +523,20 @@ subroutine radiation_init(pbuf2d) call add_vert_coord('plev_rad', nlay+1, 'Pressures at radiation flux calculations', & 'Pa', plev_rad) - call set_available_gases(active_gases, available_gases) ! gases needed to initialize spectral info + ! Create lowercase version of the gaslist for RRTMGP. The ty_gas_concs objects + ! work with CAM's uppercase names, but other objects that get input from the gas + ! concs objects don't work. + do i = 1, nradgas + gaslist_lc(i) = to_lower(gaslist(i)) + end do + + errmsg = available_gases%init(gaslist_lc) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: available_gases%init: '//trim(errmsg)) + end if call coefs_init(coefs_lw_file, kdist_lw, available_gases, band2gpt_lw) - call coefs_init(coefs_sw_file, kdist_sw, available_gases, band2gpt_sw, ref_tsi) ! bpm : these now provide band2gpt which should be global - call set_reference_tsi(ref_tsi) + call coefs_init(coefs_sw_file, kdist_sw, available_gases, band2gpt_sw) ! check number of sw/lw bands in gas optics files if (kdist_sw%get_nband() /= nswbands) then @@ -563,25 +557,11 @@ subroutine radiation_init(pbuf2d) call set_wavenumber_bands('sw', kdist_sw%get_nband(), kdist_sw%get_band_lims_wavenumber()) call set_wavenumber_bands('lw', kdist_lw%get_nband(), kdist_lw%get_band_lims_wavenumber()) - call rad_solar_var_init() ! sets the total solar irradiance (I wonder whether this should use kdist information instead of radconstants; alternative use kdist%set_tsi to ensure consistency?) call rrtmgp_inputs_init(ktopcamm, ktopradm, ktopcami, ktopradi) ! this sets these values as module data in rrtmgp_inputs call rad_data_init(pbuf2d) ! initialize output fields for offline driver call cloud_rad_props_init() - ngpt_sw = kdist_sw%get_ngpt() - - ! bpm: set the indices used for diagnostics using specific band: - call get_idx_sw_diag() ! index to sw visible band (441 - 625 nm) - call get_idx_nir_diag() ! index to sw near infrared (778-1240 nm) band - call get_idx_uv_diag() ! index to sw uv (345-441 nm) band - if (docosp) then - sw_cloudsim_band = get_band_index_by_value('sw', 0.67_r8, 'micron') ! rrtmgp band for .67 micron - lw_cloudsim_band = get_band_index_by_value('lw', 10.5_r8, 'micron') - end if - call get_idx_lw_diag() - - if (is_first_step()) then call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) end if @@ -906,7 +886,7 @@ subroutine radiation_tend( & !----------------------------------------------------------------------- ! - ! Driver for radiation computation. + ! CAM driver for radiation computation. ! !----------------------------------------------------------------------- @@ -915,7 +895,6 @@ subroutine radiation_tend( & use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz - use mo_gas_concentrations, only: ty_gas_concs use rrtmgp_inputs, only: rrtmgp_set_state, rrtmgp_set_gases_lw, rrtmgp_set_cloud_lw, & rrtmgp_set_aer_lw, rrtmgp_set_gases_sw, rrtmgp_set_cloud_sw, & rrtmgp_set_aer_sw @@ -936,8 +915,8 @@ subroutine radiation_tend( & use mo_fluxes_byband, only: ty_fluxes_byband - ! use mo_rrtmgp_clr_all_sky, only: rte_lw, rte_sw - use rrtmgp_driver, only: rte_lw, rte_sw + ! RRTMGP drivers for flux calculations. + use rrtmgp_driver, only: rte_lw, rte_sw use radheat, only: radheat_tend @@ -979,8 +958,8 @@ subroutine radiation_tend( & ! chunk_column_index = IdxDay(daylight_column_index) integer :: Nday ! Number of daylight columns integer :: Nnite ! Number of night columns - integer :: IdxDay(pcols) ! Indices of daylight columns -- Dimension is pcols, and is filled from beginning, so idxday(1:nday) are the indices of daylit columns. - integer :: IdxNite(pcols) ! Indices of night columns + integer :: IdxDay(pcols) ! chunk indices of daylight columns + integer :: IdxNite(pcols) ! chunk indices of night columns integer :: itim_old @@ -1016,7 +995,6 @@ subroutine radiation_tend( & real(r8), allocatable :: coszrs_day(:) real(r8), allocatable :: alb_dir(:,:) real(r8), allocatable :: alb_dif(:,:) - real(r8) :: tsi ! cloud radiative parameters are "in cloud" not "in cell" @@ -1074,13 +1052,12 @@ subroutine radiation_tend( & type(ty_optical_props_1scl) :: cloud_lw type(ty_optical_props_2str) :: cloud_sw - ! Irradiance integer :: icall ! index through climate/diagnostic radiation calls - logical :: active_calls(0:N_DIAG) - ! gas vmr + ! gas vmr. Separate objects because SW only does calculations for daylight columns. type(ty_gas_concs) :: gas_concs_lw type(ty_gas_concs) :: gas_concs_sw + ! RRTMGP aerosol objects type(ty_optical_props_1scl) :: aer_lw type(ty_optical_props_2str) :: aer_sw @@ -1264,13 +1241,10 @@ subroutine radiation_tend( & cam_in, & ! input (%lwup, %aldir, %asdir, %aldif, %asdif) ncol, & ! input nlay, & ! input - nlwbands, & ! input - nswbands, & ! input - ngpt_sw, & ! input nday, & ! input idxday, & ! input, [would prefer to truncate as 1:ncol] coszrs, & ! input - kdist_sw, & ! input (from init) ! removed: eccf, & ! input + kdist_sw, & ! input (from init) band2gpt_sw, & ! input (from init), gpoints by band t_sfc, & ! output emis_sfc, & ! output @@ -1282,14 +1256,10 @@ subroutine radiation_tend( & pint_day, & ! output coszrs_day, & ! output alb_dir, & ! output - alb_dif, & ! output - tsi & ! output, total solar irradiance (not scaled) - ) + alb_dif) ! output - !!--> Set TSI used in radiation to the value in the solar forcing file. - !!--> This replaces get_variability() and does same thing. - !!--> The Earth-Sun distance (eccf) provides another scaling, applied later. - errmsg = kdist_sw%set_tsi(tsi) ! scales the TSI but does not change spectral distribution + ! Set TSI used in rrtmgp to the value from CAM's solar forcing file. + errmsg = kdist_sw%set_tsi(sol_tsi) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: kdist_sw%set_tsi: '//trim(errmsg)) end if @@ -1468,16 +1438,20 @@ subroutine radiation_tend( & if (write_output) then call radiation_output_cld(lchnk, ncol, rd) end if - ! - ! SHORTWAVE CALCULATION(S) - ! - ! Get the active climate/diagnostic shortwave calculations - call rad_cnst_get_call_list(active_calls) + + !=============================! + ! SHORTWAVE flux calculations ! + !=============================! + + ! initialize object for gas concentrations + errmsg = gas_concs_sw%init(gaslist_lc) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: gas_concs_sw%init: '//trim(errmsg)) + end if ! The climate (icall==0) calculation must occur last. do icall = N_DIAG, 0, -1 if (active_calls(icall)) then - call set_available_gases(active_gases, gas_concs_sw) ! set gas concentrations call rrtmgp_set_gases_sw( & ! Put gas volume mixing ratio into gas_concs_sw icall, & ! input @@ -1576,9 +1550,10 @@ subroutine radiation_tend( & ! This happens between SW and LW (Why?) call rad_cnst_out(0, state, pbuf) - ! - ! -- LONGWAVE -- - ! + !============================! + ! LONGWAVE flux calculations ! + !============================! + if (dolw) then if (oldcldoptics) then call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) @@ -1653,23 +1628,21 @@ subroutine radiation_tend( & nlay, & kdist_lw%get_band_lims_wavenumber(), & name='longwave aerosol optics') - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: aer_lw%init_1scalar: '//trim(errmsg)) + call endrun(sub//': ERROR: aer_lw%alloc_1scalar: '//trim(errmsg)) end if - call rad_cnst_get_call_list(active_calls) ! get list of diagnostic calls + ! initialize object for gas concentrations + errmsg = gas_concs_lw%init(gaslist_lc) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR, gas_concs_lw%init: '//trim(errmsg)) + end if ! The climate (icall==0) calculation must occur last. do icall = N_DIAG, 0, -1 if (active_calls(icall)) then - ! initialize the gas concentrations - call set_available_gases(active_gases, gas_concs_lw) -! errmsg = gas_concs_lw%init(active_gases) -! if (len_trim(errmsg) > 0) then -! call endrun(sub//': ERROR code returned by gas_concs_lw%init: '//trim(errmsg)) -! end if + call rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs_lw) call aer_rad_props_lw( & ! get absorption optical depth @@ -1703,14 +1676,7 @@ subroutine radiation_tend( & aer_props=aer_lw & ! optional input, (rrtmgp_set_aer_lw) ) ! note inc_flux is an optional input, but as defined in set_rrtmgp_state, it is only for shortwave if (len_trim(errmsg) > 0) then - ! - ! DEBUG -- if we die here, find out why - ! - write(iulog,*) '** [radiation_tend] DIAGNOSE LW CRASH **' - do i = 1,ncol - write(iulog,*) 'ncol = ',ncol,' t_sfc = ',t_sfc(i),' AT LOCATION lat = ', clat(i), ' lon = ', clon(i) - end do - call endrun(sub//': ERROR code returned by rte_lw: '//trim(errmsg)) + call endrun(sub//': ERROR: rte_lw: '//trim(errmsg)) end if ! ! -- longwave output -- @@ -1743,7 +1709,7 @@ subroutine radiation_tend( & if (docosp) then ! initialize and calculate emis emis(:,:) = 0._r8 - emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(lw_cloudsim_band,:ncol,:)) + emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(idx_lw_cloudsim,:ncol,:)) call outfld('EMIS', emis, pcols, lchnk) ! compute grid-box mean SW and LW snow optical depth for use by COSP @@ -1756,13 +1722,13 @@ subroutine radiation_tend( & ! Add graupel to snow tau for cosp if (cldfgrau_idx > 0 .and. graupel_in_rad) then - gb_snow_tau(i,k) = snow_tau(sw_cloudsim_band,i,k)*cldfsnow(i,k) + & - grau_tau(sw_cloudsim_band,i,k)*cldfgrau(i,k) - gb_snow_lw(i,k) = snow_lw_abs(lw_cloudsim_band,i,k)*cldfsnow(i,k) + & - grau_lw_abs(lw_cloudsim_band,i,k)*cldfgrau(i,k) + gb_snow_tau(i,k) = snow_tau(idx_sw_cloudsim,i,k)*cldfsnow(i,k) + & + grau_tau(idx_sw_cloudsim,i,k)*cldfgrau(i,k) + gb_snow_lw(i,k) = snow_lw_abs(idx_lw_cloudsim,i,k)*cldfsnow(i,k) + & + grau_lw_abs(idx_lw_cloudsim,i,k)*cldfgrau(i,k) else - gb_snow_tau(i,k) = snow_tau(sw_cloudsim_band,i,k)*cldfsnow(i,k) - gb_snow_lw(i,k) = snow_lw_abs(lw_cloudsim_band,i,k)*cldfsnow(i,k) + gb_snow_tau(i,k) = snow_tau(idx_sw_cloudsim,i,k)*cldfsnow(i,k) + gb_snow_lw(i,k) = snow_lw_abs(idx_lw_cloudsim,i,k)*cldfsnow(i,k) end if end if end do @@ -1778,14 +1744,14 @@ subroutine radiation_tend( & ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave ! optical depths are passed. call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & - cld_swtau_in=cld_tau(sw_cloudsim_band,:,:),& + cld_swtau_in=cld_tau(idx_sw_cloudsim,:,:),& snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) cosp_cnt(lchnk) = 0 end if end if !!! *** END COSP *** - else ! if (dosw .or. dolw) --> no radiation being done. + else ! --> radiative flux calculations not updated ! convert radiative heating rates from Q*dp to Q for energy conservation ! qrs and qrl are whatever are in pbuf ! since those might have been multiplied by pdel, we actually need to divide by pdel @@ -1848,9 +1814,9 @@ subroutine radiation_tend( & call free_fluxes(flw) call free_fluxes(flwc) -!------------------------------------------------------------------------------- -contains -!------------------------------------------------------------------------------- + !------------------------------------------------------------------------------- + contains + !------------------------------------------------------------------------------- subroutine set_sw_diags() @@ -2255,18 +2221,17 @@ subroutine calc_col_mean(state, mmr_pointer, mean_value) end subroutine calc_col_mean -!=============================================================================== +!========================================================================================= -subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt, tsi_default) +subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt) ! Read data from coefficients file. Initialize the kdist object. + ! available_gases object provides the gas names that CAM provides. ! arguments character(len=*), intent(in) :: coefs_file class(ty_gas_optics_rrtmgp), intent(out) :: kdist - class(ty_gas_concs), intent(in) :: available_gases ! Which gases does the host model have available? - - real(r8), intent(out), optional :: tsi_default ! RRTMGP reference TSI + class(ty_gas_concs), intent(in) :: available_gases ! local variables type(file_desc_t) :: fh ! pio file handle @@ -2302,6 +2267,7 @@ subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt, tsi_default) real(r8), dimension(:,:), allocatable :: totplnk real(r8), dimension(:,:,:,:), allocatable :: planck_frac real(r8), dimension(:), allocatable :: solar_src_quiet, solar_src_facular, solar_src_sunspot ! updated from solar_src + real(r8) :: tsi_default real(r8), dimension(:,:,:), allocatable :: rayl_lower, rayl_upper character(len=32), dimension(:), allocatable :: gas_minor, & identifier_minor, & @@ -2540,15 +2506,6 @@ subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt, tsi_default) if (ierr /= PIO_NOERR) call endrun(sub//': error reading optimal_angle_fit') end if - ! solar_src - ! !bpm -- solar_source is not in file, there are solar_source_[facular, sunspot, quiet] - ! There's a method that adds them together to get solar_source. - ! ierr = pio_inq_varid(fh, 'solar_source', vid) - ! if (ierr == PIO_NOERR) then - ! allocate(solar_src(gpt)) - ! ierr = pio_get_var(fh, vid, solar_src) - ! if (ierr /= PIO_NOERR) call endrun(sub//': error reading solar_source') - ! end if ierr = pio_inq_varid(fh, 'solar_source_quiet', vid) if (ierr == PIO_NOERR) then allocate(solar_src_quiet(gpt)) @@ -2568,7 +2525,6 @@ subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt, tsi_default) if (ierr /= PIO_NOERR) call endrun(sub//': error reading solar_source_sunspot') end if - ! +bpm also need to have tsi_default, mg_default, and sb_default ierr = pio_inq_varid(fh, 'tsi_default', vid) if (ierr == PIO_NOERR) then ierr = pio_get_var(fh, vid, tsi_default) @@ -2836,32 +2792,7 @@ subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt, tsi_default) if (allocated(rayl_upper)) deallocate(rayl_upper) end subroutine coefs_init - - -subroutine set_available_gases(gases, gas_concentrations) - ! This subroutine is based on the E3SM implementation. -bpm - ! For each gas name in gases, initialize that gas in gas_concentrations. - use mo_gas_concentrations, only: ty_gas_concs - use mo_rrtmgp_util_string, only: lower_case - ! Arguments - type(ty_gas_concs), intent(inout) :: gas_concentrations - character(len=*), intent(in) :: gases(:) - ! Local - character(len=32), dimension(size(gases)) :: gases_lowercase - integer :: igas - character(len=128) :: error_msg - ! Initialize with lowercase gas names; we should work in lowercase - ! whenever possible because we cannot trust string comparisons in RRTMGP - ! to be case insensitive ... it *should* work regardless of case. - do igas = 1,size(gases) - gases_lowercase(igas) = trim(lower_case(gases(igas))) - end do - error_msg = gas_concentrations%init(gases_lowercase) - if (len_trim(error_msg) > 0) then - call endrun('Setting available gases. ERROR: '//trim(error_msg)) - end if -end subroutine set_available_gases - +!========================================================================================= subroutine reset_fluxes(fluxes) diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 116093add4..6823d5aaa0 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -5,11 +5,6 @@ module rrtmgp_inputs ! RRTMGP. Subset the number of model levels if CAM's top exceeds RRTMGP's ! valid domain. ! -! This code is currently set up to send RRTMGP vertical layers ordered bottom -! to top of model. Although the RRTMGP is supposed to be agnostic about the -! vertical ordering problems have arisen trying to use the top to bottom order -! as used by CAM's infrastructure. -! !-------------------------------------------------------------------------------- use shr_kind_mod, only: r8=>shr_kind_r8 @@ -21,24 +16,20 @@ module rrtmgp_inputs use physics_buffer, only: physics_buffer_desc use camsrfexch, only: cam_in_t -use radconstants, only: get_ref_solar_band_irrad, rad_gas_index -use radconstants, only: nradgas, gaslist, rrtmg_to_rrtmgp_swbands -use rad_solar_var, only: get_variability -use solar_irrad_data, only : do_spctrl_scaling, sol_tsi +use radconstants, only: nswbands, nlwbands, get_sw_spectral_boundaries +use radconstants, only: nradgas, gaslist + use rad_constituents, only: rad_cnst_get_gas use mcica_subcol_gen, only: mcica_subcol_sw, mcica_subcol_lw use mo_gas_concentrations, only: ty_gas_concs -use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp -use mo_optical_props, only: ty_optical_props, ty_optical_props_2str, ty_optical_props_1scl +use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp +use mo_optical_props, only: ty_optical_props_2str, ty_optical_props_1scl -! unneeded use mo_rrtmgp_util_string, only: lower_case -use cam_logfile, only: iulog +use cam_logfile, only: iulog use cam_abortutils, only: endrun -use cam_history, only: outfld ! just for getting ozone VMR above model top. - implicit none private save @@ -71,12 +62,18 @@ module rrtmgp_inputs integer :: ktopcami ! cam index of top interface integer :: ktopradi ! rrtmgp index of interface corresponding to ktopcami +! wavenumber (cm^-1) boundaries of shortwave bands +real(r8) :: sw_low_bounds(nswbands), sw_high_bounds(nswbands) + !================================================================================================== contains !================================================================================================== subroutine rrtmgp_inputs_init(ktcamm, ktradm, ktcami, ktradi) + ! Note that this routine must be called after the calls to set_wavenumber_bands which set + ! the sw/lw band boundaries in the radconstants module. + integer, intent(in) :: ktcamm integer, intent(in) :: ktradm integer, intent(in) :: ktcami @@ -87,27 +84,26 @@ subroutine rrtmgp_inputs_init(ktcamm, ktradm, ktcami, ktradi) ktopcami = ktcami ktopradi = ktradi + call get_sw_spectral_boundaries(sw_low_bounds, sw_high_bounds, 'cm^-1') + end subroutine rrtmgp_inputs_init !================================================================================================== subroutine rrtmgp_set_state( & - pstate, cam_in, ncol, nlay, nlwbands, & - nswbands, ngpt_sw, nday, idxday, coszrs, & - kdist_sw, & ! eccf, & !!! Removing eccf from arguments, as it is not needed here + pstate, cam_in, ncol, nlay, & + nday, idxday, coszrs, & + kdist_sw, & band2gpt_sw, & t_sfc, emis_sfc, t_rad, & pmid_rad, pint_rad, t_day, pmid_day, pint_day, & - coszrs_day, alb_dir, alb_dif, tsi) + coszrs_day, alb_dir, alb_dif) ! arguments type(physics_state), target, intent(in) :: pstate type(cam_in_t), intent(in) :: cam_in integer, intent(in) :: ncol integer, intent(in) :: nlay - integer, intent(in) :: nlwbands - integer, intent(in) :: nswbands - integer, intent(in) :: ngpt_sw integer, intent(in) :: nday integer, intent(in) :: idxday(:) real(r8), intent(in) :: coszrs(:) @@ -127,10 +123,6 @@ subroutine rrtmgp_set_state( & real(r8), intent(out) :: coszrs_day(nday) ! cosine of solar zenith angle real(r8), intent(out) :: alb_dir(nswbands,nday) ! surface albedo, direct radiation real(r8), intent(out) :: alb_dif(nswbands,nday) ! surface albedo, diffuse radiation - ! real(r8), intent(out) :: solin(ncol) ! incident flux at domain top [W/m2] - ! real(r8), intent(out) :: solar_irrad_gpt(nday,ngpt_sw) ! incident flux at domain top per gpoint [W/m2] AT DAYLIT POINTS - ! real(r8), intent(out) :: tsi_scaling_gpt(ngpt_sw) ! scale factor for irradiance by gpoint [fraction] - real(r8), intent(out) :: tsi ! total irradiance W/m2 ! local variables integer :: k, kk, i, iband @@ -139,10 +131,6 @@ subroutine rrtmgp_set_state( & real(r8) :: sfac(nswbands) ! time varying scaling factors due to Solar Spectral ! Irrad at 1 A.U. per band - real(r8) :: wavenumber_limits(2,nswbands) - - ! real(r8) :: toa_flx_by_band(nswbands) ! temporary array of incoming flux by band - ! real(r8) :: toa_flx_by_gpt(ngpt_sw) ! temporary array of incoming flux by gpt character(len=*), parameter :: sub='rrtmgp_set_state' character(len=512) :: errmsg @@ -192,65 +180,16 @@ subroutine rrtmgp_set_state( & coszrs_day(i) = coszrs(idxday(i)) end do - - ! total solar incident radiation - tsi = sol_tsi ! when using sol_tsi from solar_irrad_data, this is read from a file. - - ! TO BE REMOVED - ! We can get TSI from the solar forcing file (above). - ! We can't get the scaling here because we might not have access - ! to RRTMGP's reference irradiance on bands yet (without running kdist%gas_optics). - ! The scaling can be derived in rrtmgp_driver / rte_sw (after %gas_optics provides the toa_flux). - ! call get_ref_solar_band_irrad(solar_band_irrad) - ! call get_variability(sfac) - ! solar_band_irrad = solar_band_irrad(rrtmg_to_rrtmgp_swbands) - ! tsi = sum(solar_band_irrad(:)) ! total TSI integrated across bands, BUT NOT scaled for variability - ! ! convert from irradiance scale factor per band (sfac) to per gpoint - ! ! --> this can then be used in rrtmgp_driver module, rte_sw to scale TOA flux - ! tsi_scaling_gpt = 0.0 - - ! do iband = 1,nswbands - ! tsi_scaling_gpt(band2gpt_sw(1,iband):band2gpt_sw(2,iband)) = sfac(iband) - ! end do - - ! if we had a method to produce toa flux by gpoint, we could make that an output here. - - ! <-- begin: old way of setting albedo hard-wired to 14 SW bands --> - ! ! Surface albedo (band mapping is hardcoded for RRTMG(P) code) - ! ! This mapping assumes nswbands=14. - ! if (nswbands /= 14) & - ! call endrun(sub//': ERROR: albedo band mapping assumes nswbands=14') - - ! do i = 1, nday - ! ! Near-IR bands (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns - ! alb_dir(1:8,i) = cam_in%aldir(idxday(i)) - ! alb_dif(1:8,i) = cam_in%aldif(idxday(i)) - ! alb_dir(14,i) = cam_in%aldir(idxday(i)) - ! alb_dif(14,i) = cam_in%aldif(idxday(i)) - - ! ! Set band 24 (or, band 9 counting from 1) to use linear average of UV/visible - ! ! and near-IR values, since this band straddles 0.7 microns: - ! alb_dir(9,i) = 0.5_r8*(cam_in%aldir(idxday(i)) + cam_in%asdir(idxday(i))) - ! alb_dif(9,i) = 0.5_r8*(cam_in%aldif(idxday(i)) + cam_in%asdif(idxday(i))) - - ! ! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron - ! alb_dir(10:13,i) = cam_in%asdir(idxday(i)) - ! alb_dif(10:13,i) = cam_in%asdif(idxday(i)) - ! enddo - ! <-- end: old way of setting albedo hard-wired to 14 SW bands --> - - ! More flexible way to assign albedo (from E3SM implementation) - ! adapted here to loop over bands and cols b/c cam_in has all cols but albedos are daylit cols - ! We could remove cols loop if we just set albedos for all columns separate from rrtmgp_set_state. - ! Albedos are input as broadband (visible, and near-IR), and we need to map - ! these to appropriate bands. Bands are categorized broadly as "visible" or - ! "infrared" based on wavenumber, so we get the wavenumber limits here - wavenumber_limits = kdist_sw%get_band_lims_wavenumber() + ! Assign albedos to the daylight columns (from E3SM implementation) + ! Albedos are imported from the surface models as broadband (visible, and near-IR), + ! and we need to map these to appropriate narrower bands used in RRTMGP. Bands + ! are categorized broadly as "visible/UV" or "infrared" based on wavenumber. ! Loop over bands, and determine for each band whether it is broadly in the - ! visible or infrared part of the spectrum (visible or "not visible") + ! visible or infrared part of the spectrum based on a dividing line of + ! 0.7 micron, or 14286 cm^-1 do iband = 1,nswbands - if (is_visible(wavenumber_limits(1,iband)) .and. & - is_visible(wavenumber_limits(2,iband))) then + if (is_visible(sw_low_bounds(iband)) .and. & + is_visible(sw_high_bounds(iband))) then ! Entire band is in the visible do i = 1, nday @@ -258,8 +197,8 @@ subroutine rrtmgp_set_state( & alb_dif(iband,i) = cam_in%asdif(idxday(i)) end do - else if (.not.is_visible(wavenumber_limits(1,iband)) .and. & - .not.is_visible(wavenumber_limits(2,iband))) then + else if (.not.is_visible(sw_low_bounds(iband)) .and. & + .not.is_visible(sw_high_bounds(iband))) then ! Entire band is in the longwave (near-infrared) do i = 1, nday alb_dir(iband,i) = cam_in%aldir(idxday(i)) @@ -276,7 +215,6 @@ subroutine rrtmgp_set_state( & end if end do - ! Strictly enforce albedo bounds where (alb_dir < 0) alb_dir = 0.0_r8 @@ -292,19 +230,21 @@ subroutine rrtmgp_set_state( & end where end subroutine rrtmgp_set_state -! -! Function to check if a wavenumber is in the visible or IR +!================================================================================================== + logical function is_visible(wavenumber) + ! Wavenumber is in the visible if it is above the visible threshold + ! wavenumber, and in the infrared if it is below the threshold + ! This function doesn't distinquish between visible and UV. + ! wavenumber in inverse cm (cm^-1) real(r8), intent(in) :: wavenumber ! Threshold between visible and infrared is 0.7 micron, or 14286 cm^-1 real(r8), parameter :: visible_wavenumber_threshold = 14286._r8 ! cm^-1 - ! Wavenumber is in the visible if it is above the visible threshold - ! wavenumber, and in the infrared if it is below the threshold if (wavenumber > visible_wavenumber_threshold) then is_visible = .true. else @@ -313,29 +253,29 @@ logical function is_visible(wavenumber) end function is_visible - !================================================================================================== + function get_molar_mass_ratio(gas_name) result(massratio) ! return the molar mass ratio of dry air to gas based on gas_name character(len=*),intent(in) :: gas_name real(r8) :: massratio select case (trim(gas_name)) - case ('h2o', 'H2O') + case ('H2O') massratio = 1.607793_r8 - case ('co2', 'CO2') + case ('CO2') massratio = 0.658114_r8 - case ('o3', 'O3') + case ('O3') massratio = 0.603428_r8 - case ('ch4', 'CH4') + case ('CH4') massratio = 1.805423_r8 - case ('n2o', 'N2O') + case ('N2O') massratio = 0.658090_r8 - case ('o2', 'O2') + case ('O2') massratio = 0.905140_r8 - case ('cfc11', 'CFC11') + case ('CFC11') massratio = 0.210852_r8 - case ('cfc12', 'CFC12') + case ('CFC12') massratio = 0.239546_r8 case default call endrun("Invalid gas: "//trim(gas_name)) @@ -379,7 +319,7 @@ subroutine rad_gas_get_vmr(icall, gas_name, pstate, pbuf, nlay, numactivecols, g mmr = gas_mmr ! special case: H2O is specific humidity, not mixing ratio. Use r = q/(1-q): - if (gas_name == 'h2o') then + if (gas_name == 'H2O') then mmr = mmr / (1._r8 - mmr) end if @@ -457,7 +397,7 @@ subroutine rad_gas_get_vmr(icall, gas_name, pstate, pbuf, nlay, numactivecols, g errmsg = gas_concs%set_vmr(gas_name, gas_vmr) if (len_trim(errmsg) > 0) then - call endrun(sub//': error setting CO2: '//trim(errmsg)) + call endrun(sub//': ERROR, gas_concs%set_vmr: '//trim(errmsg)) end if deallocate(gas_vmr) diff --git a/src/physics/rrtmgp/slingo.F90 b/src/physics/rrtmgp/slingo.F90 index aedb44bcee..64d614365e 100644 --- a/src/physics/rrtmgp/slingo.F90 +++ b/src/physics/rrtmgp/slingo.F90 @@ -9,7 +9,7 @@ module slingo use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx -use radconstants, only: nswbands, nlwbands, idx_sw_diag, ot_length, idx_lw_diag, get_sw_spectral_boundaries +use radconstants, only: nswbands, nlwbands, get_sw_spectral_boundaries use cam_abortutils, only: endrun use cam_history, only: outfld @@ -80,20 +80,6 @@ subroutine slingo_rad_props_init() call cnst_get_ind('CLDLIQ', ixcldliq) call cnst_get_ind('CLDICE', ixcldice) - !call addfld ('CLWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','old In Cloud Liquid Water Path', sampling_seq='rad_lwsw') - !call addfld ('KEXT_OLD',(/ 'lev' /),'I','m^2/kg','old extinction') - !call addfld ('CLDOD_OLD',(/ 'lev' /),'I','1','old liquid OD') - !call addfld ('REL_OLD',(/ 'lev' /),'I','1','old liquid effective radius (liquid)') - - !call addfld ('CLWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Liquid Water Path', sampling_seq='rad_lwsw') - !call addfld ('KEXT_NEW',(/ 'lev' /),'I','m^2/kg','extinction') - !call addfld ('CLDOD_NEW',(/ 'lev' /),'I','1','liquid OD') - - !call addfld('CIWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path', sampling_seq='rad_lwsw') - !call addfld('CIWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path (old)', sampling_seq='rad_lwsw') - - return - end subroutine slingo_rad_props_init !============================================================================== @@ -318,12 +304,6 @@ subroutine slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, li end do ! End do k=1,pver end do ! nswbands - !call outfld('CL_OD_SW_OLD',liq_tau(idx_sw_diag,:,:), pcols, lchnk) - !call outfld('REL_OLD',rel(:,:), pcols, lchnk) - !call outfld('CLWPTH_OLD',cliqwp(:,:), pcols, lchnk) - !call outfld('KEXT_OLD',kext(:,:), pcols, lchnk) - - end subroutine slingo_liq_optics_sw subroutine slingo_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp) diff --git a/src/physics/simple/radconstants.F90 b/src/physics/simple/radconstants.F90 index b69fac1552..60585713d6 100644 --- a/src/physics/simple/radconstants.F90 +++ b/src/physics/simple/radconstants.F90 @@ -15,8 +15,6 @@ module radconstants integer, parameter, public :: idx_lw_diag = 1 integer, parameter, public :: idx_nir_diag = 1 integer, parameter, public :: idx_uv_diag = 1 -integer, parameter, public :: nrh = 1 -integer, parameter, public :: ot_length = 32 public :: rad_gas_index public :: get_lw_spectral_boundaries From e53e7077e167ce2cb9ac7fea35b9186a816f4466 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 4 Sep 2023 11:35:35 -0400 Subject: [PATCH 14/53] merge cam6_3_125 mod to rrtmg/radiation.F90 to rrtmgp --- src/physics/rrtmgp/radiation.F90 | 20 ++++---------------- 1 file changed, 4 insertions(+), 16 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 12955ae4ed..2890dec381 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -20,13 +20,9 @@ module radiation use time_manager, only: get_nstep, is_first_restart_step, & get_curr_calday, get_step_size -use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, & - rad_cnst_get_info, & - rad_cnst_get_gas, & - rad_cnst_out, & - oldcldoptics, & - liqcldoptics, & - icecldoptics +use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, & + rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & + liqcldoptics, icecldoptics use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_nir_diag, idx_uv_diag, & idx_lw_diag, idx_sw_cloudsim, idx_lw_cloudsim, & @@ -464,7 +460,6 @@ subroutine radiation_init(pbuf2d) use phys_control, only: phys_getopts use radiation_data, only: rad_data_init use cloud_rad_props, only: cloud_rad_props_init - use modal_aer_opt, only: modal_aer_opt_init use rrtmgp_inputs, only: rrtmgp_inputs_init use time_manager, only: is_first_step use radconstants, only: set_wavenumber_bands @@ -479,7 +474,7 @@ subroutine radiation_init(pbuf2d) ! -- needed for the kdist initialization routines type(ty_gas_concs) :: available_gases - integer :: i, icall, nmodes + integer :: i, icall integer :: nstep ! current timestep number logical :: history_amwg ! output the variables used by the AMWG diag package logical :: history_vdiag ! output the variables used by the AMWG variability diag package @@ -584,13 +579,6 @@ subroutine radiation_init(pbuf2d) history_budget_out = history_budget, & history_budget_histfile_num_out = history_budget_histfile_num) - ! Determine whether modal aerosols are affecting the climate, and if so - ! then initialize the modal aerosol optics module - call rad_cnst_get_info(0, nmodes=nmodes) - if (nmodes > 0) then - call modal_aer_opt_init() - end if - ! "irad_always" is number of time steps to execute radiation ! continuously from start of initial OR restart run ! _This gets used in radiation_do_ From d8edb8d8ebb9531cc3d30c2e8d145fcf53df7549 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 4 Sep 2023 20:25:17 -0400 Subject: [PATCH 15/53] mods for compatibility of rrtmgp with cam6_3_125 --- src/physics/cam/aerosol_optics_cam.F90 | 3 ++- src/physics/cam/physpkg.F90 | 11 ++++++----- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/physics/cam/aerosol_optics_cam.F90 b/src/physics/cam/aerosol_optics_cam.F90 index eb094446c8..a81e1d4701 100644 --- a/src/physics/cam/aerosol_optics_cam.F90 +++ b/src/physics/cam/aerosol_optics_cam.F90 @@ -3,7 +3,8 @@ module aerosol_optics_cam use shr_kind_mod, only: cl => shr_kind_cl use cam_logfile, only: iulog use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_uv_diag, idx_nir_diag - use radconstants, only: ot_length, get_lw_spectral_boundaries + use radconstants, only: get_lw_spectral_boundaries + use phys_prop, only: ot_length use physics_types,only: physics_state use physics_buffer,only: physics_buffer_desc use ppgrid, only: pcols, pver diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index 706b9dcdee..a5ff431d64 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -853,19 +853,22 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! low level, so init it early. Must at least do this before radiation. call wv_sat_init + ! solar irradiance data modules + call solar_data_init() + ! CAM3 prescribed aerosols if (cam3_aero_data_on) call cam3_aero_data_init(phys_state) ! Initialize rad constituents and their properties call rad_cnst_init() + + call radiation_init(pbuf2d) + call aer_rad_props_init() ! initialize carma call carma_init() - ! solar irradiance data modules - call solar_data_init() - ! Prognostic chemistry. call chem_init(phys_state,pbuf2d) @@ -904,8 +907,6 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) endif endif - call radiation_init(pbuf2d) - call cloud_diagnostics_init() call radheat_init(pref_mid) From aaf66d969cf144b2c6203df8512c70bc43a87518 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 5 Sep 2023 10:38:42 -0400 Subject: [PATCH 16/53] fix rrtmgp build-namelist mod; add missing _r8 to aerosol code --- bld/build-namelist | 6 ++++-- src/chemistry/aerosol/refractive_aerosol_optics_mod.F90 | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/bld/build-namelist b/bld/build-namelist index bd4949a80c..6d0e6b50fe 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -728,8 +728,10 @@ if ($rad_pkg =~ /rrtmg/ or $chem =~ /waccm/) { # use solar data file as the default for rrtmg and waccm_ma add_default($nl, 'solar_irrad_data_file'); - # restrict this option to just the rrtmg code - if ($rad_pkg eq 'rrtmg') { + + # This option only used by camrt and rrtmg radiation schemes. + # The solar spectral scaling is done internal to RRTMGP code. + if ($rad_pkg ne 'rrtmgp') { add_default($nl, 'solar_htng_spctrl_scl', 'val'=>'.true.'); } diff --git a/src/chemistry/aerosol/refractive_aerosol_optics_mod.F90 b/src/chemistry/aerosol/refractive_aerosol_optics_mod.F90 index a789db0383..e1289a8790 100644 --- a/src/chemistry/aerosol/refractive_aerosol_optics_mod.F90 +++ b/src/chemistry/aerosol/refractive_aerosol_optics_mod.F90 @@ -285,7 +285,7 @@ subroutine lw_props(self, ncol, ilev, iwav, pabs) do icol = 1, ncol crefin(icol) = crefin(icol) + self%watervol(icol,ilev)*self%crefwlw(iwav) - crefin(icol) = crefin(icol)/max(self%wetvol(icol,ilev), 1.e-40) + crefin(icol) = crefin(icol)/max(self%wetvol(icol,ilev), 1.e-40_r8) refr(icol) = real(crefin(icol)) refi(icol) = aimag(crefin(icol)) From 4ced2a81221a7f041058ca314fb1ea4a2339fa73 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 6 Sep 2023 08:59:05 -0400 Subject: [PATCH 17/53] remove extra ktopcam, ktoprad indices --- src/physics/rrtmgp/radconstants.F90 | 5 +- src/physics/rrtmgp/radiation.F90 | 144 ++++++++++++--------------- src/physics/rrtmgp/rrtmgp_inputs.F90 | 74 +++++--------- 3 files changed, 90 insertions(+), 133 deletions(-) diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index d086d1ce16..175e8e65b4 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -33,9 +33,8 @@ module radconstants ! GASES TREATED BY RADIATION (line spectrae) ! 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 can -! be used to initialize the ty_gas_conc object because the name matching is case -! insensitive. +! lower case strings. These upper case names are used by CAM's namelist and +! rad_constituents module. integer, public, parameter :: gasnamelength = 5 integer, public, parameter :: nradgas = 8 character(len=gasnamelength), public, parameter :: gaslist(nradgas) & diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 2890dec381..eaac53346e 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -8,7 +8,6 @@ module radiation use shr_kind_mod, only: r8=>shr_kind_r8, cl=>shr_kind_cl use spmd_utils, only: masterproc -use shr_mem_mod, only: shr_mem_getusage use ppgrid, only: pcols, pver, pverp, begchunk, endchunk use ref_pres, only: pref_edge use physics_types, only: physics_state, physics_ptend @@ -28,35 +27,25 @@ module radiation idx_lw_diag, idx_sw_cloudsim, idx_lw_cloudsim, & nradgas, gasnamelength, gaslist -use mo_gas_concentrations, only: ty_gas_concs -use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp +use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & + cospsimulator_intr_run, cosp_nradsteps + +use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active use cam_history_support, only: fillvalue, add_vert_coord use ioFileMod, only: getfil use cam_pio_utils, only: cam_pio_openfile -use pio, only: file_desc_t, & - var_desc_t, & - pio_int, & - PIO_NOERR, & - PIO_INTERNAL_ERROR, & - pio_seterrorhandling, & - PIO_BCAST_ERROR, & - pio_inq_dimlen, & - pio_inq_dimid, & - pio_inq_varid, & - pio_def_var, & - pio_put_var, & - pio_get_var, & - pio_put_att, & - PIO_NOWRITE, & - pio_closefile - -use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs +use pio, only: file_desc_t, var_desc_t, & + pio_int, pio_double, PIO_NOERR, & + pio_seterrorhandling, PIO_BCAST_ERROR, & + pio_inq_dimlen, pio_inq_dimid, pio_inq_varid, & + pio_def_var, pio_put_var, pio_get_var, & + pio_put_att, PIO_NOWRITE, pio_closefile -use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & - cospsimulator_intr_run, cosp_nradsteps +use mo_gas_concentrations, only: ty_gas_concs +use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use string_utils, only: to_lower use cam_abortutils, only: endrun @@ -205,10 +194,11 @@ module radiation ! extra layer that is added between 1 Pa and the model top. ! 2. If the WACCM model top is above 1 Pa, then RRMTGP only does calculations ! for those model layers that are below 1 Pa. -integer :: ktopcamm ! index in CAM arrays of top layer at which RRTMGP is active -integer :: ktopcami ! index in CAM arrays of top interface at which RRTMGP is active -integer :: ktopradm ! index in RRTMGP arrays of layer corresponding to CAM top layer -integer :: ktopradi ! index in RRTMGP arrays of interface corresponding to CAM top interface +integer :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which RRTMGP is active. +integer :: ktoprad ! Index in RRTMGP arrays of the layer or interface corresponding to CAM's top + ! layer or interface. + ! For CAM's top to bottom indexing, the index of a given layer + ! (midpoint) and the upper interface of that layer, are the same. ! vertical coordinate for output of fluxes on radiation grid real(r8), allocatable, target :: plev_rad(:) @@ -257,16 +247,10 @@ subroutine radiation_readnl(nlfile) character(len=cl) :: rrtmgp_coefs_lw_file, rrtmgp_coefs_sw_file - namelist /radiation_nl/ rrtmgp_coefs_lw_file, & - rrtmgp_coefs_sw_file, & - iradsw, & - iradlw, & - irad_always, & - use_rad_dt_cosz, & - spectralflux, & - use_rad_uniform_angle, & - rad_uniform_angle, & - graupel_in_rad + namelist /radiation_nl/ & + rrtmgp_coefs_lw_file, rrtmgp_coefs_sw_file, iradsw, iradlw, & + irad_always, use_rad_dt_cosz, spectralflux, use_rad_uniform_angle, & + rad_uniform_angle, graupel_in_rad !----------------------------------------------------------------------------- if (masterproc) then @@ -309,7 +293,6 @@ subroutine radiation_readnl(nlfile) call endrun(subroutine_name // ' ERROR - use_rad_uniform_angle is set to .true, but rad_uniform_angle is not set ') end if - ! Set module data coefs_lw_file = rrtmgp_coefs_lw_file coefs_sw_file = rrtmgp_coefs_sw_file @@ -369,7 +352,8 @@ subroutine radiation_register call pbuf_add_field('LD' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), ld_idx) ! longwave downward flux (per band) end if - call rad_data_register() ! if "fixed dynamical heating", this adds 4 fields to physics buffer (needed?) + ! Register fields for offline radiation driver. + call rad_data_register() end subroutine radiation_register @@ -405,6 +389,7 @@ function radiation_do(op, timestep) case default call endrun('radiation_do: unknown operation:'//op) end select + end function radiation_do !================================================================================================ @@ -452,8 +437,7 @@ end function radiation_nextsw_cday subroutine radiation_init(pbuf2d) - ! Initialize the radiation, cloud, and aerosol optics, and solar variability - ! parameterizations. + ! Initialize the radiation and cloud optics. ! Add fields to the history buffer. use physics_buffer, only: pbuf_get_index, pbuf_set_field @@ -499,19 +483,15 @@ subroutine radiation_init(pbuf2d) if (nlay == pverp) then ! Top model interface is below 1 Pa. RRTMGP is active in all model layers plus ! 1 extra layer between model top and 1 Pa. - ktopcamm = 1 - ktopcami = 1 - ktopradm = 2 - ktopradi = 2 + ktopcam = 1 + ktoprad = 2 plev_rad(1) = 1.01_r8 ! Top of extra layer, Pa. plev_rad(2:) = pref_edge else ! nlay < pverp. nlay layers are set by radiation - ktopcamm = pverp - nlay + 1 - ktopcami = pverp - nlay + 1 - ktopradm = 1 - ktopradi = 1 - plev_rad = pref_edge(ktopcami:) + ktopcam = pverp - nlay + 1 + ktoprad = 1 + plev_rad = pref_edge(ktopcam:) end if ! Define a pressure coordinate to allow output of data on the radiation grid. @@ -552,9 +532,11 @@ subroutine radiation_init(pbuf2d) call set_wavenumber_bands('sw', kdist_sw%get_nband(), kdist_sw%get_band_lims_wavenumber()) call set_wavenumber_bands('lw', kdist_lw%get_nband(), kdist_lw%get_band_lims_wavenumber()) - call rrtmgp_inputs_init(ktopcamm, ktopradm, ktopcami, ktopradi) ! this sets these values as module data in rrtmgp_inputs + call rrtmgp_inputs_init(ktopcam, ktoprad) + + ! initialize output fields for offline driver + call rad_data_init(pbuf2d) - call rad_data_init(pbuf2d) ! initialize output fields for offline driver call cloud_rad_props_init() if (is_first_step()) then @@ -588,7 +570,8 @@ subroutine radiation_init(pbuf2d) irad_always = irad_always + nstep end if - if (docosp) call cospsimulator_intr_init + if (docosp) call cospsimulator_intr_init() + allocate(cosp_cnt(begchunk:endchunk)) if (is_first_restart_step()) then cosp_cnt(begchunk:endchunk) = cosp_cnt_init @@ -808,7 +791,7 @@ subroutine radiation_define_restart(file) call pio_seterrorhandling(file, PIO_BCAST_ERROR) - ierr = pio_def_var(file, 'nextsw_cday', pio_int, nextsw_cday_desc) + ierr = pio_def_var(file, 'nextsw_cday', pio_double, nextsw_cday_desc) ierr = pio_put_att(file, nextsw_cday_desc, 'long_name', 'future radiation calday for surface models') if (docosp) then ierr = pio_def_var(File, 'cosp_cnt_init', pio_int, cospcnt_desc) @@ -1835,18 +1818,18 @@ subroutine set_sw_diags() ! fns, fcns, rd are on CAM grid (do not have "extra layer" when it is present.) do i = 1, nday - fns(idxday(i),ktopcami:) = fsw%flux_net(i, ktopradi:) - fcns(idxday(i),ktopcami:) = fswc%flux_net(i,ktopradi:) - fsds(idxday(i)) = fsw%flux_dn(i, nlay+1) - rd%fsdsc(idxday(i)) = fswc%flux_dn(i, nlay+1) - rd%fsutoa(idxday(i)) = fsw%flux_up(i, 1) - rd%fsntoa(idxday(i)) = fsw%flux_net(i, 1) ! net sw flux at TOA (*NOT* the same as fsnt) - rd%fsntoac(idxday(i)) = fswc%flux_net(i, 1) ! net sw clearsky flux at TOA (*NOT* the same as fsntc) - rd%solin(idxday(i)) = fswc%flux_dn(i, 1) - rd%flux_sw_up(idxday(i),ktopcami:) = fsw%flux_up(i,ktopradi:) - rd%flux_sw_dn(idxday(i),ktopcami:) = fsw%flux_dn(i,ktopradi:) - rd%flux_sw_clr_up(idxday(i),ktopcami:) = fswc%flux_up(i,ktopradi:) - rd%flux_sw_clr_dn(idxday(i),ktopcami:) = fswc%flux_dn(i,ktopradi:) + fns(idxday(i),ktopcam:) = fsw%flux_net(i, ktoprad:) + fcns(idxday(i),ktopcam:) = fswc%flux_net(i,ktoprad:) + fsds(idxday(i)) = fsw%flux_dn(i, nlay+1) + rd%fsdsc(idxday(i)) = fswc%flux_dn(i, nlay+1) + rd%fsutoa(idxday(i)) = fsw%flux_up(i, 1) + rd%fsntoa(idxday(i)) = fsw%flux_net(i, 1) ! net sw flux at TOA (*NOT* the same as fsnt) + rd%fsntoac(idxday(i)) = fswc%flux_net(i, 1) ! net sw clearsky flux at TOA (*NOT* the same as fsntc) + rd%solin(idxday(i)) = fswc%flux_dn(i, 1) + rd%flux_sw_up(idxday(i),ktopcam:) = fsw%flux_up(i,ktoprad:) + rd%flux_sw_dn(idxday(i),ktopcam:) = fsw%flux_dn(i,ktoprad:) + rd%flux_sw_clr_up(idxday(i),ktopcam:) = fswc%flux_up(i,ktoprad:) + rd%flux_sw_clr_dn(idxday(i),ktopcam:) = fswc%flux_dn(i,ktoprad:) rd%fsdn(idxday(i),:) = fsw%flux_dn(i,:) rd%fsdnc(idxday(i),:) = fswc%flux_dn(i,:) rd%fsup(idxday(i),:) = fsw%flux_up(i,:) @@ -1877,8 +1860,8 @@ subroutine set_sw_diags() su = 0._r8 sd = 0._r8 do i = 1, nday - su(idxday(i),ktopcami:,:) = fsw%bnd_flux_up(i,ktopradi:,:) - sd(idxday(i),ktopcami:,:) = fsw%bnd_flux_dn(i,ktopradi:,:) + su(idxday(i),ktopcam:,:) = fsw%bnd_flux_up(i,ktoprad:,:) + sd(idxday(i),ktopcam:,:) = fsw%bnd_flux_dn(i,ktoprad:,:) end do end if @@ -1923,21 +1906,20 @@ end subroutine set_sw_diags subroutine set_lw_diags() - ! Transform RRTMGP output for CAM - ! Assumes RRTMGP levels are bottom to top (though it does not care need to be consistent). - ! CAM levels are top to bottom. + ! Set CAM LW diagnostics !---------------------------------------------------------------------------- fnl = 0._r8 fcnl = 0._r8 ! RTE-RRTMGP convention for net is (down - up) **CAM assumes (up - down) !! - fnl(:ncol,ktopcami:) = -1._r8 * flw%flux_net( :, ktopradi:) - fcnl(:ncol,ktopcami:) = -1._r8 * flwc%flux_net( :, ktopradi:) - rd%flux_lw_up(:ncol,ktopcami:) = flw%flux_up( :, ktopradi:) - rd%flux_lw_clr_up(:ncol,ktopcami:) = flwc%flux_up(:, ktopradi:) - rd%flux_lw_dn(:ncol,ktopcami:) = flw%flux_dn( :, ktopradi:) - rd%flux_lw_clr_dn(:ncol,ktopcami:) = flwc%flux_dn(:, ktopradi:) + fnl(:ncol,ktopcam:) = -1._r8 * flw%flux_net( :, ktoprad:) + fcnl(:ncol,ktopcam:) = -1._r8 * flwc%flux_net( :, ktoprad:) + + rd%flux_lw_up(:ncol,ktopcam:) = flw%flux_up( :, ktoprad:) + rd%flux_lw_clr_up(:ncol,ktopcam:) = flwc%flux_up(:, ktoprad:) + rd%flux_lw_dn(:ncol,ktopcam:) = flw%flux_dn( :, ktoprad:) + rd%flux_lw_clr_dn(:ncol,ktopcam:) = flwc%flux_dn(:, ktoprad:) call heating_rate('LW', ncol, fnl, qrl) call heating_rate('LW', ncol, fcnl, rd%qrlc) @@ -1951,8 +1933,8 @@ subroutine set_lw_diags() cam_out%flwds(:ncol) = flw%flux_dn(:, nlay+1) rd%fldsc(:ncol) = flwc%flux_dn(:, nlay+1) - rd%flut(:ncol) = flw%flux_up(:, ktopradi) - rd%flutc(:ncol) = flwc%flux_up(:, ktopradi) + rd%flut(:ncol) = flw%flux_up(:, ktoprad) + rd%flutc(:ncol) = flwc%flux_up(:, ktoprad) rd%fldn(:ncol,:) = flw%flux_dn rd%fldnc(:ncol,:) = flwc%flux_dn @@ -1971,8 +1953,8 @@ subroutine set_lw_diags() if (spectralflux) then lu = 0._r8 ld = 0._r8 - lu(:ncol, ktopcami:, :) = flw%bnd_flux_up(:, ktopradi:, :) - ld(:ncol, ktopcami:, :) = flw%bnd_flux_dn(:, ktopradi:, :) + lu(:ncol, ktopcam:, :) = flw%bnd_flux_up(:, ktoprad:, :) + ld(:ncol, ktopcam:, :) = flw%bnd_flux_dn(:, ktoprad:, :) end if end subroutine set_lw_diags diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 6823d5aaa0..cceddfc3ac 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -56,11 +56,10 @@ module rrtmgp_inputs real(r8), parameter :: amdc2 = 0.239546_r8 ! Molecular weight of dry air / CFC12 ! Indices for copying data between cam and rrtmgp arrays -! Assume the rrtmgp vertical index goes bottom to top of atm -integer :: ktopcamm ! cam index of top layer -integer :: ktopradm ! rrtmgp index of layer corresponding to ktopcamm -integer :: ktopcami ! cam index of top interface -integer :: ktopradi ! rrtmgp index of interface corresponding to ktopcami +integer :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which + ! RRTMGP is active. +integer :: ktoprad ! Index in RRTMGP arrays of the layer or interface corresponding + ! to CAM's top layer or interface ! wavenumber (cm^-1) boundaries of shortwave bands real(r8) :: sw_low_bounds(nswbands), sw_high_bounds(nswbands) @@ -69,20 +68,16 @@ module rrtmgp_inputs contains !================================================================================================== -subroutine rrtmgp_inputs_init(ktcamm, ktradm, ktcami, ktradi) +subroutine rrtmgp_inputs_init(ktcam, ktrad) ! Note that this routine must be called after the calls to set_wavenumber_bands which set ! the sw/lw band boundaries in the radconstants module. - integer, intent(in) :: ktcamm - integer, intent(in) :: ktradm - integer, intent(in) :: ktcami - integer, intent(in) :: ktradi + integer, intent(in) :: ktcam + integer, intent(in) :: ktrad - ktopcamm = ktcamm - ktopradm = ktradm - ktopcami = ktcami - ktopradi = ktradi + ktopcam = ktcam + ktoprad = ktrad call get_sw_spectral_boundaries(sw_low_bounds, sw_high_bounds, 'cm^-1') @@ -519,7 +514,7 @@ subroutine rrtmgp_set_cloud_lw(state, nlwbands, cldfrac, c_cld_lw_abs, lwkDist, ! will provide zero optical depths there. cloud_lw%tau = 0.0_r8 do i = 1, ngptlw - cloud_lw%tau(:ncol, ktopradm:, i) = taucmcl(i, :ncol, ktopcamm:) + cloud_lw%tau(:ncol, ktoprad:, i) = taucmcl(i, :ncol, ktopcam:) end do errmsg = cloud_lw%validate() if (len_trim(errmsg) > 0) then @@ -546,7 +541,7 @@ subroutine rrtmgp_set_aer_lw(ncol, nlwbands, aer_lw_abs, aer_lw) ! If there is an extra layer in the radiation then this initialization ! will provide zero optical depths there. aer_lw%tau = 0.0_r8 - aer_lw%tau(:ncol, ktopradm:, :) = aer_lw_abs(:ncol, ktopcamm:, :) + aer_lw%tau(:ncol, ktoprad:, :) = aer_lw_abs(:ncol, ktopcam:, :) errmsg = aer_lw%validate() if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: aer_lw%validate: '//trim(errmsg)) @@ -602,7 +597,7 @@ subroutine rrtmgp_set_cloud_sw( & real(r8), allocatable :: day_cld_tau_w_g(:,:,:) !-------------------------------------------------------------------------------- ngptsw = kdist_sw%get_ngpt() - nver = pver - ktopcamm + 1 ! number of CAM's layers in radiation calculation. + nver = pver - ktopcam + 1 ! number of CAM's layers in radiation calculation. ! Compute the input quantities needed for the 2-stream optical props ! object. Also subset the vertical levels and the daylight columns @@ -621,10 +616,10 @@ subroutine rrtmgp_set_cloud_sw( & day_cld_tau_w_g(nswbands,nday,nver)) ! get daylit arrays on radiation levels, note: expect idxday to be truncated to size nday - day_cld_tau = c_cld_tau( :, idxday(1:nday), ktopcamm:) - day_cld_tau_w = c_cld_tau_w( :, idxday(1:nday), ktopcamm:) - day_cld_tau_w_g = c_cld_tau_w_g(:, idxday(1:nday), ktopcamm:) - cldf = cldfrac(idxday(1:nday), ktopcamm:) ! daylit cloud fraction on radiation levels + day_cld_tau = c_cld_tau( :, idxday(1:nday), ktopcam:) + day_cld_tau_w = c_cld_tau_w( :, idxday(1:nday), ktopcam:) + day_cld_tau_w_g = c_cld_tau_w_g(:, idxday(1:nday), ktopcam:) + cldf = cldfrac(idxday(1:nday), ktopcam:) ! daylit cloud fraction on radiation levels tauc = merge(day_cld_tau, 0.0_r8, day_cld_tau > 0.0_r8) ! start by setting cloud optical depth, clip @ zero asmc = merge(day_cld_tau_w_g / max(day_cld_tau_w, small_val), 0.0_r8, day_cld_tau_w > 0.0_r8) ! set value of asymmetry ssac = merge(max(day_cld_tau_w, small_val) / max(tauc, small_val), 1.0_r8 , tauc > 0.0_r8) @@ -643,14 +638,14 @@ subroutine rrtmgp_set_cloud_sw( & ! If there is an extra layer in the radiation then this initialization ! will provide the optical properties there. - ! These should be shape (ncol, nlay, ngpt); assign levels using ktopradm+k, should + ! These are shape (ncol, nlay, ngpt) cloud_sw%tau(:,:,:) = 0.0_r8 cloud_sw%ssa(:,:,:) = 1.0_r8 cloud_sw%g(:,:,:) = 0.0_r8 do igpt = 1,ngptsw - cloud_sw%g (:, ktopradm:, igpt) = asmcmcl(igpt, ktopcamm:, :) - cloud_sw%ssa(:, ktopradm:, igpt) = ssacmcl(igpt, ktopcamm:, :) - cloud_sw%tau(:, ktopradm:, igpt) = taucmcl(igpt, ktopcamm:, :) + cloud_sw%g (:, ktoprad:, igpt) = asmcmcl(igpt, ktopcam:, :) + cloud_sw%ssa(:, ktoprad:, igpt) = ssacmcl(igpt, ktopcam:, :) + cloud_sw%tau(:, ktoprad:, igpt) = taucmcl(igpt, ktopcam:, :) end do @@ -714,9 +709,11 @@ subroutine rrtmgp_set_aer_sw( & ! aer_sw is on RAD grid, aer_tau* is on CAM grid ... to make sure they align, use ktop* ! aer_sw has dimensions of (nday, nlay, nswbands) - aer_sw%tau(1:nday, ktopradm:, :) = max(aer_tau(day_cols, ktopcamm:, :), 0._r8) - aer_sw%ssa(1:nday, ktopradm:, :) = merge(aer_tau_w(day_cols, ktopcamm:,:)/aer_tau(day_cols, ktopcamm:, :), 1._r8, aer_tau(day_cols, ktopcamm:, :) > 0._r8) - aer_sw%g( 1:nday, ktopradm:, :) = merge(aer_tau_w_g(day_cols, ktopcamm:, :) / aer_tau_w(day_cols, ktopcamm:, :), 0._r8, aer_tau_w(day_cols, ktopcamm:, :) > 1.e-80_r8) + aer_sw%tau(1:nday, ktoprad:, :) = max(aer_tau(day_cols, ktopcam:, :), 0._r8) + aer_sw%ssa(1:nday, ktoprad:, :) = merge( aer_tau_w(day_cols, ktopcam:,:)/aer_tau(day_cols, ktopcam:, :), & + 1._r8, aer_tau(day_cols, ktopcam:, :) > 0._r8) + aer_sw%g( 1:nday, ktoprad:, :) = merge( aer_tau_w_g(day_cols, ktopcam:, :) / aer_tau_w(day_cols, ktopcam:, :), & + 0._r8, aer_tau_w(day_cols, ktopcam:, :) > 1.e-80_r8) ! impose limits on the components: ! aer_sw%tau = max(aer_sw%tau, 0._r) <-- already imposed @@ -734,25 +731,4 @@ end subroutine rrtmgp_set_aer_sw !================================================================================================== -subroutine expand_and_transpose(ops,arr_in,arr_out) - ! based on version in mo_rte_sw - class(ty_gas_optics_rrtmgp), intent(in) :: ops ! spectral information - real(r8), dimension(:), intent(in ) :: arr_in ! (nband) - real(r8), dimension(:), intent(out) :: arr_out ! (igpt) - ! ------------- - integer :: nband, ngpt - integer :: iband, igpt - integer, dimension(2,ops%get_nband()) :: limits - - nband = ops%get_nband() - ngpt = ops%get_ngpt() - limits = ops%get_band_lims_gpoint() - do iband = 1, nband - do igpt = limits(1, iband), limits(2, iband) - arr_out(igpt) = arr_in(iband) - end do - end do - - end subroutine expand_and_transpose - end module rrtmgp_inputs From 9d433323e6ba563f824715e7218e750541bf6353 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 6 Sep 2023 10:45:15 -0400 Subject: [PATCH 18/53] remove unused arg band2gpt --- src/physics/rrtmgp/radiation.F90 | 98 ++++++++++------------------ src/physics/rrtmgp/rrtmgp_inputs.F90 | 35 ++++------ 2 files changed, 45 insertions(+), 88 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index eaac53346e..e8d6119a4a 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -207,10 +207,6 @@ module radiation type(ty_gas_optics_rrtmgp) :: kdist_lw type(ty_gas_optics_rrtmgp) :: kdist_sw -! data to go from bands to gpoints -integer, allocatable :: band2gpt_sw(:,:) -integer, allocatable :: band2gpt_lw(:,:) - ! Mapping from RRTMG shortwave bands to RRTMGP. Currently needed to continue using ! the SW optics datasets from RRTMG (even thought there is a slight mismatch in the ! band boundaries of the 2 bands that overlap with the LW bands). @@ -510,8 +506,9 @@ subroutine radiation_init(pbuf2d) call endrun(sub//': ERROR: available_gases%init: '//trim(errmsg)) end if - call coefs_init(coefs_lw_file, kdist_lw, available_gases, band2gpt_lw) - call coefs_init(coefs_sw_file, kdist_sw, available_gases, band2gpt_sw) + ! Read RRTMGP coefficients files and initialize kdist objects. + call coefs_init(coefs_lw_file, available_gases, kdist_lw) + call coefs_init(coefs_sw_file, available_gases, kdist_sw) ! check number of sw/lw bands in gas optics files if (kdist_sw%get_nband() /= nswbands) then @@ -1206,28 +1203,12 @@ subroutine radiation_tend( & alb_dif(nswbands,nday) & ) - - call rrtmgp_set_state( & ! Prepares state variables, daylit columns, albedos for RRTMGP - state, & ! input (%t, %pmid, %pint) - cam_in, & ! input (%lwup, %aldir, %asdir, %aldif, %asdif) - ncol, & ! input - nlay, & ! input - nday, & ! input - idxday, & ! input, [would prefer to truncate as 1:ncol] - coszrs, & ! input - kdist_sw, & ! input (from init) - band2gpt_sw, & ! input (from init), gpoints by band - t_sfc, & ! output - emis_sfc, & ! output - t_rad, & ! output - pmid_rad, & ! output - pint_rad, & ! output - t_day, & ! output - pmid_day, & ! output - pint_day, & ! output - coszrs_day, & ! output - alb_dir, & ! output - alb_dif) ! output + ! Prepares state variables, daylit columns, albedos for RRTMGP + call rrtmgp_set_state( & + state, cam_in, ncol, nlay, nday, & + idxday, coszrs, kdist_sw, t_sfc, emis_sfc, & + t_rad, pmid_rad, pint_rad, t_day, pmid_day, & + pint_day, coszrs_day, alb_dir, alb_dif) ! Set TSI used in rrtmgp to the value from CAM's solar forcing file. errmsg = kdist_sw%set_tsi(sol_tsi) @@ -2193,19 +2174,19 @@ end subroutine calc_col_mean !========================================================================================= -subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt) +subroutine coefs_init(coefs_file, available_gases, kdist) ! Read data from coefficients file. Initialize the kdist object. ! available_gases object provides the gas names that CAM provides. ! arguments character(len=*), intent(in) :: coefs_file - class(ty_gas_optics_rrtmgp), intent(out) :: kdist class(ty_gas_concs), intent(in) :: available_gases + class(ty_gas_optics_rrtmgp), intent(out) :: kdist ! local variables type(file_desc_t) :: fh ! pio file handle - character(len=256) :: locfn ! path to actual file used + character(len=256) :: locfn ! path to file on local storage ! File dimensions integer :: & @@ -2214,7 +2195,7 @@ subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt) bnd, & pressure, & temperature, & - absorber_ext, & ! replaces `major_absorber` + absorber_ext, & pressure_interp, & mixing_fraction, & gpt, & @@ -2226,8 +2207,8 @@ subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt) character(32), dimension(:), allocatable :: gas_names integer, dimension(:,:,:), allocatable :: key_species - integer, dimension(:,:), allocatable, intent(out) :: band2gpt ! -> file : 'bnd_limits_gpt' - real(r8), dimension(:,:), allocatable :: band_lims_wavenum ! -> file : 'bnd_limits_wavenumber' + integer, dimension(:,:), allocatable :: band2gpt + real(r8), dimension(:,:), allocatable :: band_lims_wavenum real(r8), dimension(:), allocatable :: press_ref, temp_ref real(r8) :: press_ref_trop, temp_ref_t, temp_ref_p real(r8), dimension(:,:,:), allocatable :: vmr_ref @@ -2662,35 +2643,22 @@ subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt) ! gas_optics%load() returns a string; a non-empty string indicates an error. ! if (allocated(totplnk) .and. allocated(planck_frac)) then - error_msg = kdist%load(available_gases, gas_names, key_species, & - band2gpt, & - band_lims_wavenum, & - press_ref, & - press_ref_trop, & - temp_ref, & - temp_ref_p, & - temp_ref_t, & - vmr_ref, & - kmajor, & - kminor_lower, & - kminor_upper, & - gas_minor, & - identifier_minor, & - minor_gases_lower, & - minor_gases_upper, & - minor_limits_gpt_lower, & - minor_limits_gpt_upper, & - minor_scales_with_density_lower, & - minor_scales_with_density_upper, & - scaling_gas_lower, & - scaling_gas_upper, & - scale_by_complement_lower, & - scale_by_complement_upper, & - kminor_start_lower, & - kminor_start_upper, & - totplnk, planck_frac, & - rayl_lower, rayl_upper, & - optimal_angle_fit) + error_msg = kdist%load( & + available_gases, gas_names, key_species, & + band2gpt, band_lims_wavenum, & + press_ref, press_ref_trop, temp_ref, & + temp_ref_p, temp_ref_t, vmr_ref, & + kmajor, kminor_lower, kminor_upper, & + gas_minor, identifier_minor, & + minor_gases_lower, minor_gases_upper, & + minor_limits_gpt_lower, minor_limits_gpt_upper, & + minor_scales_with_density_lower, & + minor_scales_with_density_upper, & + scaling_gas_lower, scaling_gas_upper, & + scale_by_complement_lower, scale_by_complement_upper, & + kminor_start_lower, kminor_start_upper, & + totplnk, planck_frac, rayl_lower, rayl_upper, & + optimal_angle_fit) else if (allocated(solar_src_quiet)) then error_msg = kdist%load(available_gases, & gas_names, & @@ -2738,7 +2706,7 @@ subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt) deallocate( & gas_names, key_species, & - band_lims_wavenum, & + band2gpt, band_lims_wavenum, & press_ref, temp_ref, vmr_ref, & kmajor, kminor_lower, kminor_upper, & gas_minor, identifier_minor, & @@ -2751,7 +2719,7 @@ subroutine coefs_init(coefs_file, kdist, available_gases, band2gpt) scale_by_complement_lower, & scale_by_complement_upper, & kminor_start_lower, kminor_start_upper) - ! did not deallocate band2gpt because we want to use it later (changed it to intent(out), bpm) + if (allocated(optimal_angle_fit)) deallocate(optimal_angle_fit) if (allocated(totplnk)) deallocate(totplnk) if (allocated(planck_frac)) deallocate(planck_frac) diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index cceddfc3ac..ca439a61dc 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -86,27 +86,21 @@ end subroutine rrtmgp_inputs_init !================================================================================================== subroutine rrtmgp_set_state( & - pstate, cam_in, ncol, nlay, & - nday, idxday, coszrs, & - kdist_sw, & - band2gpt_sw, & - t_sfc, emis_sfc, t_rad, & - pmid_rad, pint_rad, t_day, pmid_day, pint_day, & - coszrs_day, alb_dir, alb_dif) + pstate, cam_in, ncol, nlay, nday, & + idxday, coszrs, kdist_sw, t_sfc, emis_sfc, & + t_rad, pmid_rad, pint_rad, t_day, pmid_day, & + pint_day, coszrs_day, alb_dir, alb_dif) ! arguments - type(physics_state), target, intent(in) :: pstate - type(cam_in_t), intent(in) :: cam_in - integer, intent(in) :: ncol - integer, intent(in) :: nlay - integer, intent(in) :: nday - integer, intent(in) :: idxday(:) - real(r8), intent(in) :: coszrs(:) - ! real(r8), intent(in) :: eccf ! Earth orbit eccentricity factor - integer, intent(in) :: band2gpt_sw(:,:) !< (2, nswbands) - + type(physics_state), intent(in) :: pstate ! CAM physics state + type(cam_in_t), intent(in) :: cam_in ! CAM import state + integer, intent(in) :: ncol ! # cols in chunk + integer, intent(in) :: nlay ! # layers in rrtmgp grid + integer, intent(in) :: nday ! # daylight columns + integer, intent(in) :: idxday(:) ! chunk indicies of daylight columns + real(r8), intent(in) :: coszrs(:) ! cosine of solar zenith angle class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! spectral information -!!! CHECK pcols vs ncol !!! + real(r8), intent(out) :: t_sfc(ncol) ! surface temperature [K] real(r8), intent(out) :: emis_sfc(nlwbands,ncol) ! emissivity at surface [] real(r8), intent(out) :: t_rad(ncol,nlay) ! layer midpoint temperatures [K] @@ -122,11 +116,6 @@ subroutine rrtmgp_set_state( & ! local variables integer :: k, kk, i, iband - real(r8) :: solar_band_irrad(nswbands) ! specified solar irradiance in each sw band (per radconstants) - - real(r8) :: sfac(nswbands) ! time varying scaling factors due to Solar Spectral - ! Irrad at 1 A.U. per band - character(len=*), parameter :: sub='rrtmgp_set_state' character(len=512) :: errmsg !-------------------------------------------------------------------------------- From 0d2ca48e7927fedc61ca6c0c2c4650db4165ae91 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 6 Sep 2023 12:47:14 -0400 Subject: [PATCH 19/53] refactor set_wavenumber_bands --- src/physics/rrtmgp/radconstants.F90 | 119 ++++++++++++++++++---------- src/physics/rrtmgp/radiation.F90 | 31 +++----- 2 files changed, 88 insertions(+), 62 deletions(-) diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index 175e8e65b4..aa90f2050b 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -3,8 +3,9 @@ module radconstants ! This module contains constants that are specific to the radiative transfer ! code used in the RRTMGP model. -use shr_kind_mod, only: r8 => shr_kind_r8 -use cam_abortutils, only: endrun +use shr_kind_mod, only: r8 => shr_kind_r8 +use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp +use cam_abortutils, only: endrun implicit none private @@ -18,10 +19,12 @@ module radconstants integer, parameter, public :: nlwbands = 16 ! Band limits (set from data in RRTMGP coefficient datasets) -real(r8), allocatable, target :: wavenumber_low_shortwave(:) -real(r8), allocatable, target :: wavenumber_high_shortwave(:) -real(r8), allocatable, target :: wavenumber_low_longwave(:) -real(r8), allocatable, target :: wavenumber_high_longwave(:) +real(r8), target :: wavenumber_low_shortwave(nswbands) +real(r8), target :: wavenumber_high_shortwave(nswbands) +real(r8), target :: wavenumber_low_longwave(nlwbands) +real(r8), target :: wavenumber_high_longwave(nlwbands) + +logical :: wavenumber_boundaries_set = .false. ! These are indices to specific bands for diagnostic output and COSP input. integer, public, protected :: idx_sw_diag = -1 ! band contains 500-nm wave @@ -50,46 +53,68 @@ module radconstants get_band_index_by_value, & rad_gas_index -!=============================================================================== +!========================================================================================= contains -!=============================================================================== +!========================================================================================= -subroutine set_wavenumber_bands(swlw, nbands, values) +subroutine set_wavenumber_bands(kdist_sw, kdist_lw) - ! Set the low and high limits of the wavenumber grid for sw or lw. - ! Values comes from RRTMGP coefficients datasets. - ! Also set band indices for bands containing specific wavelengths. + ! Set the low and high limits of the wavenumber grid for sw and lw. + ! Values comes from RRTMGP coefficients datasets, and are stored in the + ! kdist objects. Also set band indices for bands containing specific wavelengths. - character(*), intent(in) :: swlw ! which bands to set ['sw', 'lw'] - integer, intent(in) :: nbands - real(r8), intent(in) :: values(2,nbands) ! cm-1 + ! Arguments + type(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw + type(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw - select case(swlw) - case ('sw') - allocate(wavenumber_low_shortwave(nbands)) - allocate(wavenumber_high_shortwave(nbands)) - wavenumber_low_shortwave = values(1,:) - wavenumber_high_shortwave = values(2,:) + ! Local variables + real(r8), allocatable :: values(:,:) - idx_sw_diag = get_band_index_by_value('sw', 500.0_r8, 'nm') - idx_nir_diag = get_band_index_by_value('sw', 1000.0_r8, 'nm') - idx_uv_diag = get_band_index_by_value('sw', 400._r8, 'nm') - idx_sw_cloudsim = get_band_index_by_value('sw', 0.67_r8, 'micron') + character(len=128) :: errmsg + character(len=*), parameter :: sub = 'set_wavenumber_bands' + !---------------------------------------------------------------------------- - case ('lw') - allocate(wavenumber_low_longwave(nbands)) - allocate(wavenumber_high_longwave(nbands)) - wavenumber_low_longwave = values(1,:) - wavenumber_high_longwave = values(2,:) + ! Check that number of sw/lw bands in gas optics files matches the parameters. + if (kdist_sw%get_nband() /= nswbands) then + write(errmsg,'(a,i4,a,i4)') 'number of sw bands in file, ', kdist_sw%get_nband(), & + ", doesn't match parameter nswbands= ", nswbands + call endrun(sub//': ERROR: '//trim(errmsg)) + end if + if (kdist_lw%get_nband() /= nlwbands) then + write(errmsg,'(a,i4,a,i4)') 'number of lw bands in file, ', kdist_lw%get_nband(), & + ", doesn't match parameter nlwbands= ", nlwbands + call endrun(sub//': ERROR: '//trim(errmsg)) + end if - idx_lw_diag = get_band_index_by_value('lw', 1000.0_r8, 'cm^-1') - idx_lw_cloudsim = get_band_index_by_value('lw', 10.5_r8, 'micron') + ! SW band bounds in cm^-1 + allocate( values(2,nswbands) ) + values = kdist_sw%get_band_lims_wavenumber() + wavenumber_low_shortwave = values(1,:) + wavenumber_high_shortwave = values(2,:) - end select + ! Indices into specific bands + idx_sw_diag = get_band_index_by_value('sw', 500.0_r8, 'nm') + idx_nir_diag = get_band_index_by_value('sw', 1000.0_r8, 'nm') + idx_uv_diag = get_band_index_by_value('sw', 400._r8, 'nm') + idx_sw_cloudsim = get_band_index_by_value('sw', 0.67_r8, 'micron') + + deallocate(values) + + ! LW band bounds in cm^-1 + allocate( values(2,nlwbands) ) + values = kdist_lw%get_band_lims_wavenumber() + wavenumber_low_longwave = values(1,:) + wavenumber_high_longwave = values(2,:) + + ! Indices into specific bands + idx_lw_diag = get_band_index_by_value('lw', 1000.0_r8, 'cm^-1') + idx_lw_cloudsim = get_band_index_by_value('lw', 10.5_r8, 'micron') + + wavenumber_boundaries_set = .true. end subroutine set_wavenumber_bands -!------------------------------------------------------------------------------ +!========================================================================================= subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) @@ -98,6 +123,13 @@ subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) real(r8), intent(out) :: low_boundaries(nswbands), high_boundaries(nswbands) character(*), intent(in) :: units ! requested units + character(len=*), parameter :: sub = 'get_sw_spectral_boundaries' + !---------------------------------------------------------------------------- + + if (.not. wavenumber_boundaries_set) then + call endrun(sub//': ERROR, wavenumber boundaries not set. ') + end if + select case (units) case ('inv_cm','cm^-1','cm-1') low_boundaries = wavenumber_low_shortwave @@ -115,12 +147,12 @@ subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) low_boundaries = 1._r8/wavenumber_high_shortwave high_boundaries = 1._r8/wavenumber_low_shortwave case default - call endrun('rad_constants.F90: requested spectral units not recognized: '//units) + call endrun(sub//': ERROR, requested spectral units not recognized: '//units) end select end subroutine get_sw_spectral_boundaries -!------------------------------------------------------------------------------ +!========================================================================================= subroutine get_lw_spectral_boundaries(low_boundaries, high_boundaries, units) @@ -129,6 +161,13 @@ subroutine get_lw_spectral_boundaries(low_boundaries, high_boundaries, units) real(r8), intent(out) :: low_boundaries(nlwbands), high_boundaries(nlwbands) character(*), intent(in) :: units ! requested units + character(len=*), parameter :: sub = 'get_lw_spectral_boundaries' + !---------------------------------------------------------------------------- + + if (.not. wavenumber_boundaries_set) then + call endrun(sub//': ERROR, wavenumber boundaries not set. ') + end if + select case (units) case ('inv_cm','cm^-1','cm-1') low_boundaries = wavenumber_low_longwave @@ -146,12 +185,12 @@ subroutine get_lw_spectral_boundaries(low_boundaries, high_boundaries, units) low_boundaries = 1._r8/wavenumber_high_longwave high_boundaries = 1._r8/wavenumber_low_longwave case default - call endrun('get_lw_spectral_boundaries: spectral units not recognized: '//units) + call endrun(sub//': ERROR, requested spectral units not recognized: '//units) end select end subroutine get_lw_spectral_boundaries -!------------------------------------------------------------------------------ +!========================================================================================= integer function rad_gas_index(gasname) @@ -170,7 +209,7 @@ integer function rad_gas_index(gasname) call endrun ("rad_gas_index: can not find gas with name "//gasname) end function rad_gas_index -!------------------------------------------------------------------------------ +!========================================================================================= function get_band_index_by_value(swlw, targetvalue, units) result(ans) @@ -231,6 +270,6 @@ function get_band_index_by_value(swlw, targetvalue, units) result(ans) end function get_band_index_by_value -!------------------------------------------------------------------------------ +!========================================================================================= end module radconstants diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index e8d6119a4a..51da2ddbb6 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -204,8 +204,8 @@ module radiation real(r8), allocatable, target :: plev_rad(:) ! Gas optics objects contain the data read from the coefficients files. -type(ty_gas_optics_rrtmgp) :: kdist_lw type(ty_gas_optics_rrtmgp) :: kdist_sw +type(ty_gas_optics_rrtmgp) :: kdist_lw ! Mapping from RRTMG shortwave bands to RRTMGP. Currently needed to continue using ! the SW optics datasets from RRTMG (even thought there is a slight mismatch in the @@ -305,12 +305,14 @@ subroutine radiation_readnl(nlfile) if (masterproc) then write(iulog,*) 'RRTMGP radiation scheme parameters:' - write(iulog,10) trim(coefs_lw_file), trim(coefs_sw_file), iradsw, iradlw, & - irad_always, use_rad_dt_cosz, spectralflux, graupel_in_rad + write(iulog,10) trim(coefs_lw_file), trim(coefs_sw_file), nlwbands, nswbands, & + iradsw, iradlw, irad_always, use_rad_dt_cosz, spectralflux, graupel_in_rad end if 10 format(' LW coefficents file: ', a/, & ' SW coefficents file: ', a/, & + ' Number of LW bands: ',i5/, & + ' Number of SW bands: ',i5/, & ' Frequency (timesteps) of Shortwave Radiation calc: ',i5/, & ' Frequency (timesteps) of Longwave Radiation calc: ',i5/, & ' SW/LW calc done every timestep for first N steps. N=',i5/, & @@ -507,28 +509,13 @@ subroutine radiation_init(pbuf2d) end if ! Read RRTMGP coefficients files and initialize kdist objects. - call coefs_init(coefs_lw_file, available_gases, kdist_lw) call coefs_init(coefs_sw_file, available_gases, kdist_sw) + call coefs_init(coefs_lw_file, available_gases, kdist_lw) - ! check number of sw/lw bands in gas optics files - if (kdist_sw%get_nband() /= nswbands) then - write(errmsg,'(a,i4,a,i4)') 'number of sw bands in file, ', kdist_sw%get_nband(), & - ", doesn't match parameter nswbands= ", nswbands - call endrun(sub//': ERROR: '//trim(errmsg)) - end if - if (kdist_lw%get_nband() /= nlwbands) then - write(errmsg,'(a,i4,a,i4)') 'number of lw bands in file, ', kdist_lw%get_nband(), & - ", doesn't match parameter nlwbands= ", nlwbands - call endrun(sub//': ERROR: '//trim(errmsg)) - end if - if (masterproc) then - write(iulog, *) sub//': NUMBER SW BANDS: ', nswbands,' NUMBER LW BANDS: ', nlwbands - end if - - ! set the sw/lw band limits in radconstants - call set_wavenumber_bands('sw', kdist_sw%get_nband(), kdist_sw%get_band_lims_wavenumber()) - call set_wavenumber_bands('lw', kdist_lw%get_nband(), kdist_lw%get_band_lims_wavenumber()) + ! Set the sw/lw band boundaries in radconstants + call set_wavenumber_bands(kdist_sw, kdist_lw) + ! The spectral band boundaries need to be set before this init is called. call rrtmgp_inputs_init(ktopcam, ktoprad) ! initialize output fields for offline driver From 2b3abb82d81b1aa0ff5fedf50193a1a4c4c6456c Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 6 Sep 2023 16:56:13 -0400 Subject: [PATCH 20/53] refactor rrtmgp_set_state --- src/physics/rrtmgp/radconstants.F90 | 6 +- src/physics/rrtmgp/radiation.F90 | 48 +++++--------- src/physics/rrtmgp/rrtmgp_inputs.F90 | 95 +++++++++++++++------------- 3 files changed, 71 insertions(+), 78 deletions(-) diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index aa90f2050b..a04cbef23d 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -60,8 +60,10 @@ module radconstants subroutine set_wavenumber_bands(kdist_sw, kdist_lw) ! Set the low and high limits of the wavenumber grid for sw and lw. - ! Values comes from RRTMGP coefficients datasets, and are stored in the - ! kdist objects. Also set band indices for bands containing specific wavelengths. + ! Values come from RRTMGP coefficients datasets, and are stored in the + ! kdist objects. + ! + ! Set band indices for bands containing specific wavelengths. ! Arguments type(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 51da2ddbb6..bb1bb1df32 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -11,21 +11,27 @@ module radiation use ppgrid, only: pcols, pver, pverp, begchunk, endchunk use ref_pres, only: pref_edge use physics_types, only: physics_state, physics_ptend -use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx +use phys_control, only: phys_getopts +use physics_buffer, only: physics_buffer_desc, pbuf_add_field, dtype_r8, pbuf_get_index, & + pbuf_set_field, pbuf_get_field, pbuf_old_tim_idx use camsrfexch, only: cam_out_t, cam_in_t use physconst, only: cappa, cpair, gravit use solar_irrad_data, only: sol_tsi -use time_manager, only: get_nstep, is_first_restart_step, & +use time_manager, only: get_nstep, is_first_step, is_first_restart_step, & get_curr_calday, get_step_size use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, & rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & liqcldoptics, icecldoptics +use rrtmgp_inputs, only: rrtmgp_inputs_init + use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_nir_diag, idx_uv_diag, & idx_lw_diag, idx_sw_cloudsim, idx_lw_cloudsim, & - nradgas, gasnamelength, gaslist + nradgas, gasnamelength, gaslist, set_wavenumber_bands + +use cloud_rad_props, only: cloud_rad_props_init use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & cospsimulator_intr_run, cosp_nradsteps @@ -35,6 +41,8 @@ module radiation use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active use cam_history_support, only: fillvalue, add_vert_coord +use radiation_data, only: rad_data_register, rad_data_init + use ioFileMod, only: getfil use cam_pio_utils, only: cam_pio_openfile use pio, only: file_desc_t, var_desc_t, & @@ -229,7 +237,6 @@ subroutine radiation_readnl(nlfile) ! Read radiation_nl namelist group. use namelist_utils, only: find_group_name - use units, only: getunit, freeunit use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical, & mpi_character @@ -250,8 +257,7 @@ subroutine radiation_readnl(nlfile) !----------------------------------------------------------------------------- if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) + open( newunit=unitn, file=trim(nlfile), status='old' ) call find_group_name(unitn, 'radiation_nl', status=ierr) if (ierr == 0) then read(unitn, radiation_nl, iostat=ierr) @@ -260,7 +266,6 @@ subroutine radiation_readnl(nlfile) end if end if close(unitn) - call freeunit(unitn) end if ! Broadcast namelist variables @@ -326,9 +331,6 @@ end subroutine radiation_readnl subroutine radiation_register - use physics_buffer, only: pbuf_add_field, dtype_r8 - use radiation_data, only: rad_data_register - ! Register radiation fields in the physics buffer call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate @@ -438,14 +440,6 @@ subroutine radiation_init(pbuf2d) ! Initialize the radiation and cloud optics. ! Add fields to the history buffer. - use physics_buffer, only: pbuf_get_index, pbuf_set_field - use phys_control, only: phys_getopts - use radiation_data, only: rad_data_init - use cloud_rad_props, only: cloud_rad_props_init - use rrtmgp_inputs, only: rrtmgp_inputs_init - use time_manager, only: is_first_step - use radconstants, only: set_wavenumber_bands - ! arguments type(physics_buffer_desc), pointer :: pbuf2d(:,:) @@ -463,7 +457,7 @@ subroutine radiation_init(pbuf2d) logical :: history_budget ! output tendencies and state variables for CAM4 ! temperature, water vapor, cloud ice and cloud ! liquid budgets. - integer :: history_budget_histfile_num ! output history file number for budget fields + integer :: history_budget_histfile_num ! history file number for budget fields integer :: ierr integer :: dtime @@ -1177,18 +1171,10 @@ subroutine radiation_tend( & if (dosw .or. dolw) then allocate( & - t_sfc(ncol), & - emis_sfc(nlwbands,ncol), & - 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_sfc(ncol), emis_sfc(nlwbands,ncol), & + 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) ) ! Prepares state variables, daylit columns, albedos for RRTMGP call rrtmgp_set_state( & diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index ca439a61dc..1a1d3da55d 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -10,7 +10,7 @@ module rrtmgp_inputs use shr_kind_mod, only: r8=>shr_kind_r8 use ppgrid, only: pcols, pver, pverp -use physconst, only: stebol +use physconst, only: stebol, pi use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc @@ -83,16 +83,16 @@ subroutine rrtmgp_inputs_init(ktcam, ktrad) end subroutine rrtmgp_inputs_init -!================================================================================================== +!========================================================================================= subroutine rrtmgp_set_state( & - pstate, cam_in, ncol, nlay, nday, & + state, cam_in, ncol, nlay, nday, & idxday, coszrs, kdist_sw, t_sfc, emis_sfc, & t_rad, pmid_rad, pint_rad, t_day, pmid_day, & pint_day, coszrs_day, alb_dir, alb_dif) ! arguments - type(physics_state), intent(in) :: pstate ! CAM physics state + type(physics_state), intent(in) :: state ! CAM physics state type(cam_in_t), intent(in) :: cam_in ! CAM import state integer, intent(in) :: ncol ! # cols in chunk integer, intent(in) :: nlay ! # layers in rrtmgp grid @@ -116,6 +116,8 @@ subroutine rrtmgp_set_state( & ! local variables integer :: k, kk, i, iband + real(r8) :: tref_min, tref_max, tmin, tmax + character(len=*), parameter :: sub='rrtmgp_set_state' character(len=512) :: errmsg !-------------------------------------------------------------------------------- @@ -124,39 +126,42 @@ subroutine rrtmgp_set_state( & ! Set surface emissivity to 1.0. ! The land model *does* have its own surface emissivity, but is not spectrally resolved. - ! The LW upward flux is calculated with that land emissivity, and the "radiative temperature" t_sfc is derived - ! from that flux. We assume, therefore, that the emissivity is unity to be consistent with t_sfc. + ! The LW upward flux is calculated with that land emissivity, and the "radiative temperature" + ! t_sfc is derived from that flux. We assume, therefore, that the emissivity is unity + ! to be consistent with t_sfc. emis_sfc(:,:) = 1._r8 + ! Assume level ordering is the same for both CAM and RRTMGP (top to bottom) + t_rad(:,ktoprad:) = state%t(:ncol,ktopcam:) + pmid_rad(:,ktoprad:) = state%pmid(:ncol,ktopcam:) + pint_rad(:,ktoprad:) = state%pint(:ncol,ktopcam:) - ! Assume level ordering is the same for both CAM and RAD (top to bottom) - if (nlay == pver) then - t_rad(:ncol, :) = pstate%t(:ncol, :) - pmid_rad(:ncol, :) = pstate%pmid(:ncol, :) - pint_rad(:ncol, :) = pstate%pint(:ncol, :) - else if (nlay < pver) then - t_rad(:ncol, :) = pstate%t(:ncol, pver-nlay+1:pver) - pmid_rad(:ncol, :) = pstate%pmid(:ncol, pver-nlay+1:pver) - pint_rad(:ncol, :) = pstate%pint(:ncol, pver-nlay+1:pverp) - else if (nlay > pver) then - t_rad(:ncol, nlay-pver+1:) = pstate%t(:ncol, :) - pmid_rad(:ncol, nlay-pver+1:) = pstate%pmid(:ncol, :) - pint_rad(:ncol, nlay-pver+1:) = pstate%pint(:ncol, :) + ! Add extra layer values if needed. + if (nlay == pverp) then + t_rad(:,1) = state%t(:ncol,1) + pmid_rad(:,1) = 0.5_r8 * state%pint(:ncol,1) + ! The top reference pressure from the RRTMGP coefficients datasets is 1.005183574463 Pa + ! Set the top of the extra layer just below that. + pint_rad(:,1) = 1.01_r8 end if - - if (nlay == pverp) then - ! add midpoint and top interface values for extra layer - t_rad(:,1) = pstate%t(:ncol,1) - pmid_rad(:,1) = 0.5_r8 * pstate%pint(:ncol,1) - - ! pint_rad(:,nlay+1) = 1.e-2_r8 ! rrtmg value (in hPa?) - pint_rad(:,1) = 1.01_r8 ! in Pa - else if (nlay > pverp) then - call endrun(sub//': ERROR: radiation should not have more layers than CAM has interfaces') + ! Check that the temperatures are within the limits of RRTMGP validity. + tref_min = kdist_sw%get_temp_min() + tref_max = kdist_sw%get_temp_max() + if ( any(t_rad < tref_min) .or. any(t_rad > tref_max) ) then + ! Find out of range value and quit. + do i = 1, ncol + do k = 1, nlay + if ( t_rad(i,k) < tref_min .or. t_rad(i,k) > tref_max ) then + write(errmsg,*) 'temp outside valid range: ', t_rad(i,k), ': column lat=', & + state%lat(i)*180._r8/pi, ': column lon=', state%lon(i)*180._r8/pi, ': level idx=',k + call endrun(sub//': ERROR, '//errmsg) + end if + end do + end do end if - ! properties needed at day columns + ! Construct arrays containing only daylight columns do i = 1, nday t_day(i,:) = t_rad(idxday(i),:) pmid_day(i,:) = pmid_rad(idxday(i),:) @@ -215,7 +220,7 @@ subroutine rrtmgp_set_state( & end subroutine rrtmgp_set_state -!================================================================================================== +!========================================================================================= logical function is_visible(wavenumber) @@ -237,7 +242,7 @@ logical function is_visible(wavenumber) end function is_visible -!================================================================================================== +!========================================================================================= function get_molar_mass_ratio(gas_name) result(massratio) ! return the molar mass ratio of dry air to gas based on gas_name @@ -266,12 +271,12 @@ function get_molar_mass_ratio(gas_name) result(massratio) end select end function get_molar_mass_ratio -subroutine rad_gas_get_vmr(icall, gas_name, pstate, pbuf, nlay, numactivecols, gas_concs, indices) +subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, gas_concs, indices) ! provides volume mixing ratio into gas_concs data structure ! Assumes gas_name will be found with rad_cnst_get_gas(). integer, intent(in) :: icall ! index of climate/diagnostic radiation call character(len=*), intent(in) :: gas_name - type(physics_state), target, intent(in) :: pstate + type(physics_state), target, intent(in) :: state type(physics_buffer_desc), pointer :: pbuf(:) integer, intent(in) :: nlay ! number of layers in radiation calculation integer, intent(in) :: numactivecols ! number of columns, ncol for LW, nday for SW @@ -298,7 +303,7 @@ subroutine rad_gas_get_vmr(icall, gas_name, pstate, pbuf, nlay, numactivecols, g allocate(mmr(numactivecols, nlay)) allocate(gas_vmr(numactivecols, nlay)) - call rad_cnst_get_gas(icall, gas_name, pstate, pbuf, gas_mmr) + call rad_cnst_get_gas(icall, gas_name, state, pbuf, gas_mmr) ! copy the gas and actually convert to mmr in case of H2O (specific to mixing ratio) mmr = gas_mmr @@ -352,8 +357,8 @@ subroutine rad_gas_get_vmr(icall, gas_name, pstate, pbuf, nlay, numactivecols, g amdo = get_molar_mass_ratio('O3') do i = 1, numactivecols P_top = 50.0_r8 ! pressure (Pa) at which we assume O3 = 0 in linear decay from CAM top - P_int(i) = pstate%pint(idx(i),1) ! pressure (Pa) at upper interface of CAM - P_mid(i) = pstate%pmid(idx(i),1) ! pressure (Pa) at midpoint of top layer of CAM + P_int(i) = state%pint(idx(i),1) ! pressure (Pa) at upper interface of CAM + P_mid(i) = state%pmid(idx(i),1) ! pressure (Pa) at midpoint of top layer of CAM alpha(i) = 0.0_r8 beta(i) = 0.0_r8 alpha(i) = log(P_int(i)/P_top) @@ -391,7 +396,7 @@ end subroutine rad_gas_get_vmr !================================================================================================== -subroutine rrtmgp_set_gases_lw(icall, pstate, pbuf, nlay, gas_concs) +subroutine rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs) ! The gases in the LW coefficients file are: ! H2O, CO2, O3, N2O, CO, CH4, O2, N2 @@ -404,7 +409,7 @@ subroutine rrtmgp_set_gases_lw(icall, pstate, pbuf, nlay, gas_concs) ! arguments integer, intent(in) :: icall ! index of climate/diagnostic radiation call - type(physics_state), target, intent(in) :: pstate + type(physics_state), target, intent(in) :: state type(physics_buffer_desc), pointer :: pbuf(:) integer, intent(in) :: nlay type(ty_gas_concs), intent(inout) :: gas_concs @@ -417,17 +422,17 @@ subroutine rrtmgp_set_gases_lw(icall, pstate, pbuf, nlay, gas_concs) integer :: i !-------------------------------------------------------------------------------- - ncol = pstate%ncol - lchnk = pstate%lchnk + ncol = state%ncol + lchnk = state%lchnk do i = 1,nradgas - call rad_gas_get_vmr(icall, gaslist(i), pstate, pbuf, nlay, ncol, gas_concs) + call rad_gas_get_vmr(icall, gaslist(i), state, pbuf, nlay, ncol, gas_concs) end do end subroutine rrtmgp_set_gases_lw !================================================================================================== subroutine rrtmgp_set_gases_sw( & - icall, pstate, pbuf, nlay, nday, & + icall, state, pbuf, nlay, nday, & idxday, gas_concs) ! Return gas_concs with gas volume mixing ratio on DAYLIT columns. @@ -439,7 +444,7 @@ subroutine rrtmgp_set_gases_sw( & ! arguments integer, intent(in) :: icall ! index of climate/diagnostic radiation call - type(physics_state), target, intent(in) :: pstate + type(physics_state), target, intent(in) :: state type(physics_buffer_desc), pointer :: pbuf(:) integer, intent(in) :: nlay integer, intent(in) :: nday @@ -452,7 +457,7 @@ subroutine rrtmgp_set_gases_sw( & ! use the optional argument indices to specify which columns are sunlit do i = 1,nradgas - call rad_gas_get_vmr(icall, gaslist(i), pstate, pbuf, nlay, nday, gas_concs, indices=idxday) + call rad_gas_get_vmr(icall, gaslist(i), state, pbuf, nlay, nday, gas_concs, indices=idxday) end do end subroutine rrtmgp_set_gases_sw From a889343ee9d423b1a70f2b110c8477cde6c019cb Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 7 Sep 2023 10:46:06 -0400 Subject: [PATCH 21/53] refactor modified_cloud_fraction --- src/physics/rrtmgp/radiation.F90 | 152 +++++++++++++++---------------- 1 file changed, 72 insertions(+), 80 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index bb1bb1df32..fc66554bd8 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -162,7 +162,7 @@ module radiation ! initial or restart run logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. -logical :: graupel_in_rad = .false. ! graupel in radiation code +logical :: graupel_in_rad = .false. ! graupel in radiation code logical :: use_rad_uniform_angle = .false. ! if true, use the namelist rad_uniform_angle for the coszrs calculation ! active_calls is set by a rad_constituents method after parsing namelist input @@ -227,9 +227,9 @@ module radiation type(var_desc_t) :: cospcnt_desc ! cosp type(var_desc_t) :: nextsw_cday_desc -!=============================================================================== +!========================================================================================= contains -!=============================================================================== +!========================================================================================= subroutine radiation_readnl(nlfile) @@ -517,6 +517,10 @@ subroutine radiation_init(pbuf2d) call cloud_rad_props_init() + cld_idx = pbuf_get_index('CLD') + cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=ierr) + cldfgrau_idx = pbuf_get_index('CLDFGRAU',errcode=ierr) + if (is_first_step()) then call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) end if @@ -539,9 +543,8 @@ subroutine radiation_init(pbuf2d) history_budget_out = history_budget, & history_budget_histfile_num_out = history_budget_histfile_num) - ! "irad_always" is number of time steps to execute radiation - ! continuously from start of initial OR restart run - ! _This gets used in radiation_do_ + ! "irad_always" is number of time steps to execute radiation continuously from + ! start of initial OR restart run nstep = get_nstep() if (irad_always > 0) then nstep = get_nstep() @@ -557,7 +560,6 @@ subroutine radiation_init(pbuf2d) cosp_cnt(begchunk:endchunk) = 0 end if - ! Add fields to history buffer call addfld('TOT_CLD_VISTAU', (/ 'lev' /), 'A', '1', & @@ -573,6 +575,17 @@ subroutine radiation_init(pbuf2d) 'Ice in-cloud extinction visible sw optical depth', & sampling_seq='rad_lwsw', flag_xyfill=.true.) + if (cldfsnow_idx > 0) then + call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', & + 'Snow in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + end if + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + call addfld('GRAU_ICLD_VISTAU', (/ 'lev' /), 'A', '1', & + 'Graupel in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + endif + ! get list of active radiation calls call rad_cnst_get_call_list(active_calls) @@ -638,7 +651,7 @@ subroutine radiation_init(pbuf2d) call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') - ! Fluxes on rrtmgp grid + ! Fluxes on RRTMGP grid call addfld('FSDN'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW downward flux on rrtmgp grid') call addfld('FSDNC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW downward clear sky flux on rrtmgp grid') call addfld('FSUP'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW upward flux on rrtmgp grid') @@ -662,6 +675,13 @@ subroutine radiation_init(pbuf2d) end if end do + if (scm_crm_mode) then + call add_default('FUS ', 1, ' ') + call add_default('FUSC ', 1, ' ') + call add_default('FDS ', 1, ' ') + call add_default('FDSC ', 1, ' ') + endif + ! Add longwave radiation fields to history master field list. do icall = 0, N_DIAG @@ -721,9 +741,14 @@ subroutine radiation_init(pbuf2d) end if end do - call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') ! COSP-related output + call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') - ! NOTE: HIRS/MSU diagnostic brightness temperatures are removed. + if (scm_crm_mode) then + call add_default ('FUL ', 1, ' ') + call add_default ('FULC ', 1, ' ') + call add_default ('FDL ', 1, ' ') + call add_default ('FDLC ', 1, ' ') + endif ! Heating rate needed for d(theta)/dt computation call addfld ('HR',(/ 'lev' /), 'A','K/s','Heating rate needed for d(theta)/dt computation') @@ -738,20 +763,6 @@ subroutine radiation_init(pbuf2d) call add_default('FLUT', 3, ' ') end if - cld_idx = pbuf_get_index('CLD') - cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=ierr) - cldfgrau_idx = pbuf_get_index('CLDFGRAU',errcode=ierr) - if (cldfsnow_idx > 0) then - call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', & - 'Snow in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - end if - if (cldfgrau_idx > 0 .and. graupel_in_rad) then - call addfld('GRAU_ICLD_VISTAU', (/ 'lev' /), 'A', '1', & - 'Graupel in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - endif - end subroutine radiation_init !=============================================================================== @@ -913,8 +924,8 @@ subroutine radiation_tend( & integer :: itim_old real(r8), pointer :: cld(:,:) ! cloud fraction - real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds"- whatever they are - real(r8), pointer :: cldfgrau(:,:) ! cloud fraction of just "graupel clouds"- whatever they are + real(r8), pointer :: cldfsnow(:,:) => null() ! cloud fraction of just "snow clouds"- whatever they are + real(r8), pointer :: cldfgrau(:,:) => null() ! cloud fraction of just "graupel clouds"- whatever they are real(r8), pointer :: qrs(:,:) => null() ! shortwave radiative heating rate real(r8), pointer :: qrl(:,:) => null() ! longwave radiative heating rate real(r8), pointer :: fsds(:) ! Surface solar down flux @@ -1011,10 +1022,8 @@ subroutine radiation_tend( & type(ty_optical_props_1scl) :: aer_lw type(ty_optical_props_2str) :: aer_sw - ! Fluxes - ! These are used locally only. SW fluxes are on day columns only. - ! "Output" (i.e. diagnostic) fluxes are provided with rd, fsns, fcns, fnl, fcnl, etc. - ! see set_sw_diags and radiation_output_sw and radiation_output_lw + ! Flux objects contain all fluxes computed by RRTMGP. Includes spectrally resolved and + ! total fluxes for all levels of the RRTMGP grid. type(ty_fluxes_byband) :: fsw, fswc type(ty_fluxes_byband) :: flw, flwc @@ -1024,9 +1033,10 @@ subroutine radiation_tend( & real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux - real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity ! for COSP - real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau ! for COSP - real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth ! for COSP + ! for COSP + real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity + real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau + real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables @@ -1037,9 +1047,6 @@ subroutine radiation_tend( & logical :: conserve_energy = .false. ! Flag to carry (QRS,QRL)*dp across time steps. - integer :: iband - real(r8) :: mem_hw_end, mem_hw_beg, mem_end, mem_beg, temp - !-------------------------------------------------------------------------------------- lchnk = state%lchnk @@ -1095,11 +1102,7 @@ subroutine radiation_tend( & ! Associate pointers to physics buffer fields itim_old = pbuf_old_tim_idx() if (cldfsnow_idx > 0) then - call pbuf_get_field(pbuf, & - cldfsnow_idx, & - cldfsnow, & - start=(/1,1,itim_old/), & - kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) end if if (cldfgrau_idx > 0 .and. graupel_in_rad) then call pbuf_get_field(pbuf, cldfgrau_idx, cldfgrau, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) @@ -1139,8 +1142,7 @@ subroutine radiation_tend( & ! Find tropopause height if needed for diagnostic output if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then - call tropopause_find(state, troplev, tropP=p_trop, & - primary=TROP_ALG_HYBSTOB, & + call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, & backup=TROP_ALG_CLIMATE) end if @@ -1183,19 +1185,14 @@ subroutine radiation_tend( & t_rad, pmid_rad, pint_rad, t_day, pmid_day, & pint_day, coszrs_day, alb_dir, alb_dif) - ! Set TSI used in rrtmgp to the value from CAM's solar forcing file. + ! Set TSI for RRTMGP to the value from CAM's solar forcing file. errmsg = kdist_sw%set_tsi(sol_tsi) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: kdist_sw%set_tsi: '//trim(errmsg)) end if - ! check bounds for temperature -- These are specified in the coefficients file, - ! and RRTMGP will not operate if outside the specified range. - call clipper(t_day, kdist_lw%get_temp_min(), kdist_lw%get_temp_max()) - call clipper(t_rad, kdist_lw%get_temp_min(), kdist_lw%get_temp_max()) - - ! Modify cloud fraction to account for radiatively active snow and/or graupel - call modified_cloud_fraction(cld, cldfsnow, cldfgrau, cldfsnow_idx, cldfgrau_idx, cldfprime) + ! Modified cloud fraction accounts for radiatively active snow and/or graupel + call modified_cloud_fraction(ncol, cld, cldfsnow, cldfgrau, cldfprime) if (dosw) then @@ -1293,10 +1290,6 @@ subroutine radiation_tend( & ! At this point we have cloud optical properties including snow and graupel, ! but they need to be re-ordered from the old RRTMG spectral bands to RRTMGP's - ! - ! Mapping from old RRTMG sw bands to new band ordering in RRTMGP - ! 1. This should be automated to provide generalization to arbitrary spectral grid. - ! 2. This is used for setting cloud and aerosol optical properties, so probably should be put into a different module. c_cld_tau(:,1:ncol,1:pver) = c_cld_tau (rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) c_cld_tau_w(:,1:ncol,1:pver) = c_cld_tau_w (rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) c_cld_tau_w_g(:,1:ncol,1:pver) = c_cld_tau_w_g(rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) @@ -2766,6 +2759,7 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct) end subroutine initialize_rrtmgp_fluxes +!========================================================================================= subroutine initialize_rrtmgp_cloud_optics_sw(ncol, nlevels, kdist, optics) ! use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp ! module level @@ -2845,31 +2839,29 @@ subroutine free_fluxes(fluxes) if (associated(fluxes%bnd_flux_dn_dir)) deallocate(fluxes%bnd_flux_dn_dir) end subroutine free_fluxes +!========================================================================================= -subroutine modified_cloud_fraction(cld, cldfsnow, cldfgrau, cldfsnow_idx, cldfgrau_idx, cldfprime) - real(r8), pointer :: cld(:,:) ! cloud fraction - real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds"- whatever they are - real(r8), pointer :: cldfgrau(:,:) ! cloud fraction of just "graupel clouds"- whatever they are - integer, intent(in) :: cldfsnow_idx ! physics buffer index for snow cloud fraction - integer, intent(in) :: cldfgrau_idx ! physics buffer index for graupel cloud fraction - real(r8), intent(inout) :: cldfprime(:,:) ! combined cloud fraction (snow plus regular) - integer :: k,i,ncol,nlev - - ! graupel_in_rad is module data from namelist. - ! pcols is "physics columns" and comes from module data. - ! pver is "physics vertical levels" and comes from module data. +subroutine modified_cloud_fraction(ncol, cld, cldfsnow, cldfgrau, cldfprime) + ! Compute modified cloud fraction, cldfprime. ! 1. initialize as cld - ! 2. check whether to modify for snow, where snow is, use max(cld, cldfsnow) - ! 3. check whether to modify for graupel, where graupel, use max(cldfprime, cldfgrau) - ! -- use cldfprime as it will already be modified for snow if necessary, and equal to cld if not. + ! 2. modify for snow if cldfsnow is available. use max(cld, cldfsnow) + ! 3. modify for graupel if cldfgrau is available and graupel_in_rad is true. + ! use max(cldfprime, cldfgrau) - ncol = size(cld,1) - nlev = size(cld,2) - cldfprime(1:ncol, 1:nlev) = cld(1:ncol, 1:nlev) ! originally nlev here was pver + ! Arguments + integer, intent(in) :: ncol + real(r8), pointer :: cld(:,:) ! cloud fraction + real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds" + real(r8), pointer :: cldfgrau(:,:) ! cloud fraction of just "graupel clouds" + real(r8), intent(out) :: cldfprime(:,:) ! modified cloud fraction - if (cldfsnow_idx > 0) then - do k = 1, nlev + ! Local variables + integer :: i, k + !---------------------------------------------------------------------------- + + if (associated(cldfsnow)) then + do k = 1, pver do i = 1, ncol cldfprime(i,k) = max(cld(i,k), cldfsnow(i,k)) end do @@ -2878,8 +2870,8 @@ subroutine modified_cloud_fraction(cld, cldfsnow, cldfgrau, cldfsnow_idx, cldfgr cldfprime(:ncol,:) = cld(:ncol,:) end if - if (cldfgrau_idx > 0 .and. graupel_in_rad) then - do k = 1, nlev + if (associated(cldfgrau) .and. graupel_in_rad) then + do k = 1, pver do i = 1, ncol cldfprime(i,k) = max(cldfprime(i,k), cldfgrau(i,k)) end do @@ -2888,9 +2880,8 @@ subroutine modified_cloud_fraction(cld, cldfsnow, cldfgrau, cldfsnow_idx, cldfgr end subroutine modified_cloud_fraction -! -! a simple clipping subroutine -! +!========================================================================================= + elemental subroutine clipper(scalar, minval, maxval) real(r8), intent(inout) :: scalar real(r8), intent(in) :: minval, maxval @@ -2904,6 +2895,7 @@ elemental subroutine clipper(scalar, minval, maxval) end if end subroutine clipper +!========================================================================================= end module radiation From 4752c0ae278f28271e83e1964d2546af93feb027 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 7 Sep 2023 11:52:29 -0400 Subject: [PATCH 22/53] bug fix - pmid_day arg should not have levels reversed --- src/physics/rrtmgp/radiation.F90 | 20 ++++---------------- 1 file changed, 4 insertions(+), 16 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index fc66554bd8..fe8a6665cc 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1298,20 +1298,10 @@ subroutine radiation_tend( & ! cloud_sw : cloud optical properties. call initialize_rrtmgp_cloud_optics_sw(nday, nlay, kdist_sw, cloud_sw) - call rrtmgp_set_cloud_sw( & ! the result cloud_sw is gpoints ("quadrature" points) - nswbands, & ! input - nday, & ! input - nlay, & ! input - idxday(1:ncol), & ! input, [require to truncate to 1 to ncol b/c the array is size pcol] - pmid_day(:,nlay:1:-1), & ! input - cldfprime, & ! input - c_cld_tau, & ! input - c_cld_tau_w, & ! input - c_cld_tau_w_g, & ! input - c_cld_tau_w_f, & ! input - kdist_sw, & ! input - cloud_sw & ! inout, outputs %g, %ssa, %tau - ) + call rrtmgp_set_cloud_sw( & + nswbands, nday, nlay, idxday, pmid_day, & + cldfprime, c_cld_tau, c_cld_tau_w, c_cld_tau_w_g, c_cld_tau_w_f, & + kdist_sw, cloud_sw) ! allocate object for aerosol optics errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber(), & @@ -1324,8 +1314,6 @@ subroutine radiation_tend( & ! SHORTWAVE DIAGNOSTICS & OUTPUT ! ! cloud optical depth fields for the visible band - ! This uses idx_sw_diag to get a specific band; - ! is hard-coded in radconstants and is correct for RRTMGP ordering. rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) ! should be equal to cloud_sw%tau except ordering rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) From 3c9ce1423972cce4d223ee04a8d9e069ee2c023d Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 7 Sep 2023 18:48:38 -0400 Subject: [PATCH 23/53] refactor and bug fix in rad_gas_get_vmr --- src/physics/rrtmgp/radiation.F90 | 13 +-- src/physics/rrtmgp/rrtmgp_inputs.F90 | 167 ++++++++++++--------------- 2 files changed, 75 insertions(+), 105 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index fe8a6665cc..f5c468f1c6 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1359,15 +1359,10 @@ subroutine radiation_tend( & do icall = N_DIAG, 0, -1 if (active_calls(icall)) then - call rrtmgp_set_gases_sw( & ! Put gas volume mixing ratio into gas_concs_sw - icall, & ! input - state, & ! input ; note: state/pbuf are top-to-bottom - pbuf, & ! input - nlay, & ! input - nday, & ! input - idxday, & ! input [this is full array, but could be 1:nday] - gas_concs_sw & ! inout ; will be bottom-to-top !! concentrations will be size ncol, but only 1:nday should be used - ) + ! Set gas volume mixing ratios for this call in gas_concs_sw. + call rrtmgp_set_gases_sw( & + icall, state, pbuf, nlay, nday, & + idxday, gas_concs_sw) call aer_rad_props_sw( & ! Get aerosol shortwave optical properties icall, & ! input diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 1a1d3da55d..600b714141 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -271,119 +271,103 @@ function get_molar_mass_ratio(gas_name) result(massratio) end select end function get_molar_mass_ratio -subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, gas_concs, indices) - ! provides volume mixing ratio into gas_concs data structure - ! Assumes gas_name will be found with rad_cnst_get_gas(). - integer, intent(in) :: icall ! index of climate/diagnostic radiation call - character(len=*), intent(in) :: gas_name - type(physics_state), target, intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - integer, intent(in) :: nlay ! number of layers in radiation calculation - integer, intent(in) :: numactivecols ! number of columns, ncol for LW, nday for SW +!========================================================================================= + +subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, gas_concs, idxday) + + ! Set volume mixing ratio in gas_concs data structure. - type(ty_gas_concs), intent(inout) :: gas_concs ! the result is VRM inside gas_concs + integer, intent(in) :: icall ! index of climate/diagnostic radiation call + character(len=*), intent(in) :: gas_name + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: nlay ! number of layers in radiation calculation + integer, intent(in) :: numactivecols ! number of columns, ncol for LW, nday for SW - integer, intent(in), OPTIONAL :: indices(:) ! this would be idxday, providing the indices of the active columns + type(ty_gas_concs), intent(inout) :: gas_concs ! the result is VRM inside gas_concs + + integer, optional, intent(in) :: idxday(:) ! indices of daylight columns in a chunk ! local + integer :: i, idx(numactivecols) real(r8), pointer :: gas_mmr(:,:) real(r8), allocatable :: gas_vmr(:,:) - character(len=128) :: errmsg real(r8), allocatable :: mmr(:,:) - character(len=*), parameter :: sub = 'rad_gas_get_vmr' + real(r8) :: massratio + ! -- for ozone profile above model - real(r8), allocatable :: P_int(:), P_mid(:), alpha(:), beta(:), a(:), b(:), chi_mid(:), chi_0(:), chi_eff(:) - real(r8) :: P_top - integer :: idx(numactivecols) - integer :: i - real(r8) :: alpha_value - real(r8) :: amdo !! alpha_value of ozone + real(r8) :: P_top, P_int, P_mid, alpha, beta, a, b, chi_mid, chi_0, chi_eff + + character(len=128) :: errmsg + character(len=*), parameter :: sub = 'rad_gas_get_vmr' + !---------------------------------------------------------------------------- + ! set the column indices; when idxday is provided (e.g. daylit columns) use them, otherwise just count. + do i = 1, numactivecols + if (present(idxday)) then + idx(i) = idxday(i) + else + idx(i) = i + end if + end do + ! gas_mmr points to a "chunk" in either the state or pbuf objects. That storage is + ! dimensioned (pcols,pver). + call rad_cnst_get_gas(icall, gas_name, state, pbuf, gas_mmr) + + ! Copy into storage for RRTMGP allocate(mmr(numactivecols, nlay)) allocate(gas_vmr(numactivecols, nlay)) - call rad_cnst_get_gas(icall, gas_name, state, pbuf, gas_mmr) - ! copy the gas and actually convert to mmr in case of H2O (specific to mixing ratio) + do i = 1, numactivecols + mmr(i,ktoprad:) = gas_mmr(idx(i),ktopcam:) + end do + + ! If an extra layer is being used, copy mmr from the top layer of CAM to the extra layer. + if (nlay == pverp) then + mmr(:,1) = mmr(:,2) + end if - mmr = gas_mmr ! special case: H2O is specific humidity, not mixing ratio. Use r = q/(1-q): if (gas_name == 'H2O') then mmr = mmr / (1._r8 - mmr) end if ! convert MMR to VMR, multipy by ratio of dry air molar mas to gas molar mass. - alpha_value = get_molar_mass_ratio(gas_name) - - ! set the column indices; when indices is provided (e.g. daylit columns) use them, otherwise just count. - do i = 1,numactivecols - if (present(indices)) then - idx(i) = indices(i) - else - idx(i) = i - end if - end do - - - if (nlay == pver) then - do i = 1,numactivecols - gas_vmr(i, :pver) = mmr(idx(i),:pver) * alpha_value - end do - else if (nlay < pver) then ! radiation calculation doesn't go through atmospheric depth - do i = 1,numactivecols - gas_vmr(i,nlay+1-pver:) = mmr(idx(i),:pver) * alpha_value - end do - else if (nlay > pver) then ! radiation has more layers than atmosphere --> only one extra layer allowed, so could say gas_vmr(:ncol, 2:) = gas_mmr(:ncol, :pver)*amdc - do i = 1,numactivecols - gas_vmr(i,nlay+1-pver:) = mmr(idx(i),:pver) * alpha_value - end do - if (nlay == pverp) then - gas_vmr(:,1) = gas_vmr(:,nlay+1-pver) - else - call endrun(sub//': Radiation can not have more than 1 extra layer.') - end if - end if + massratio = get_molar_mass_ratio(gas_name) + gas_vmr = mmr * massratio - ! special case: O3 + ! special case: Setting O3 in the extra layer: ! - ! """ ! For the purpose of attenuating solar fluxes above the CAM model top, we assume that ozone ! mixing decreases linearly in each column from the value in the top layer of CAM to zero at ! the pressure level set by P_top. P_top has been set to 50 Pa (0.5 hPa) based on model tuning ! to produce temperatures at the top of CAM that are most consistent with WACCM at similar pressure levels. - ! """ + if ((gas_name == 'O3') .and. (nlay == pverp)) then - allocate(P_int(numactivecols), P_mid(numactivecols), alpha(numactivecols), beta(numactivecols), a(numactivecols), b(numactivecols), chi_mid(numactivecols), chi_0(numactivecols), chi_eff(numactivecols)) - amdo = get_molar_mass_ratio('O3') do i = 1, numactivecols - P_top = 50.0_r8 ! pressure (Pa) at which we assume O3 = 0 in linear decay from CAM top - P_int(i) = state%pint(idx(i),1) ! pressure (Pa) at upper interface of CAM - P_mid(i) = state%pmid(idx(i),1) ! pressure (Pa) at midpoint of top layer of CAM - alpha(i) = 0.0_r8 - beta(i) = 0.0_r8 - alpha(i) = log(P_int(i)/P_top) - beta(i) = log(P_mid(i)/P_int(i))/log(P_mid(i)/P_top) + P_top = 50.0_r8 + P_int = state%pint(idx(i),1) ! pressure (Pa) at upper interface of CAM + P_mid = state%pmid(idx(i),1) ! pressure (Pa) at midpoint of top layer of CAM + alpha = 0.0_r8 + beta = 0.0_r8 + alpha = log(P_int/P_top) + beta = log(P_mid/P_int)/log(P_mid/P_top) - a(i) = ( (1._r8 + alpha(i)) * exp(-alpha(i)) - 1._r8 ) / alpha(i) - b(i) = 1._r8 - exp(-alpha(i)) + a = ( (1._r8 + alpha) * exp(-alpha) - 1._r8 ) / alpha + b = 1._r8 - exp(-alpha) - if (alpha(i) .gt. 0) then ! only apply where top level is below 80 km - chi_mid(i) = mmr(i,1)*amdo ! molar mixing ratio of O3 at midpoint of top layer - chi_0(i) = chi_mid(i) / (1._r8 + beta(i)) - chi_eff(i) = chi_0(i) * (a(i) + b(i)) - gas_vmr(i,1) = chi_eff(i) - chi_eff(i) = chi_eff(i) * P_int(i) / amdo / 9.8_r8 ! O3 column above in kg m-2 - chi_eff(i) = chi_eff(i) / 2.1415e-5_r8 ! O3 column above in DU + if (alpha .gt. 0) then ! only apply where top level is below 80 km + chi_mid = gas_vmr(i,1) ! molar mixing ratio of O3 at midpoint of top layer + chi_0 = chi_mid / (1._r8 + beta) + chi_eff = chi_0 * (a + b) + gas_vmr(i,1) = chi_eff + chi_eff = chi_eff * P_int / massratio / 9.8_r8 ! O3 column above in kg m-2 + chi_eff = chi_eff / 2.1415e-5_r8 ! O3 column above in DU end if end do - deallocate(P_int, P_mid, alpha, beta, a, b, chi_mid, chi_0, chi_eff) end if - ! other special cases: - ! N2 and CO: If these are in the gas list, would set them to constants - ! as in E3SM. Currently, these will abort run because they are not found by rad_cnst_get_gas. - ! So while RTE-RRTMGP can cope with them, we do not use them for radiation at this time. - errmsg = gas_concs%set_vmr(gas_name, gas_vmr) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR, gas_concs%set_vmr: '//trim(errmsg)) @@ -398,9 +382,7 @@ end subroutine rad_gas_get_vmr subroutine rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs) - ! The gases in the LW coefficients file are: - ! H2O, CO2, O3, N2O, CO, CH4, O2, N2 - ! But we only use the gases in the radconstants module's gaslist. + ! Set gas vmr for the gases in the radconstants module's gaslist. ! The memory management for the gas_concs object is internal. The arrays passed to it ! are copied to the internally allocated memory. Each call to the set_vmr method checks @@ -415,16 +397,12 @@ subroutine rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs) type(ty_gas_concs), intent(inout) :: gas_concs ! local variables - integer :: ncol - - integer :: lchnk + integer :: i, ncol character(len=*), parameter :: sub = 'rrtmgp_set_gases_lw' - integer :: i !-------------------------------------------------------------------------------- ncol = state%ncol - lchnk = state%lchnk - do i = 1,nradgas + do i = 1, nradgas call rad_gas_get_vmr(icall, gaslist(i), state, pbuf, nlay, ncol, gas_concs) end do end subroutine rrtmgp_set_gases_lw @@ -436,11 +414,7 @@ subroutine rrtmgp_set_gases_sw( & idxday, gas_concs) ! Return gas_concs with gas volume mixing ratio on DAYLIT columns. - - ! The gases in the SW coefficients file are: - ! H2O, CO2, O3, N2O, CO, CH4, O2, N2, CCL4, CFC11, CFC12, CFC22, HFC143a, - ! HFC125, HFC23, HFC32, HFC134a, CF4, NO2 - ! We only use the gases in radconstants gaslist. + ! Set all gases in radconstants gaslist. ! arguments integer, intent(in) :: icall ! index of climate/diagnostic radiation call @@ -452,12 +426,13 @@ subroutine rrtmgp_set_gases_sw( & type(ty_gas_concs), intent(inout) :: gas_concs ! local variables - character(len=*), parameter :: sub = 'rrtmgp_set_gases_sw' integer :: i + character(len=*), parameter :: sub = 'rrtmgp_set_gases_sw' + !---------------------------------------------------------------------------- - ! use the optional argument indices to specify which columns are sunlit + ! use the optional argument idxday to specify which columns are sunlit do i = 1,nradgas - call rad_gas_get_vmr(icall, gaslist(i), state, pbuf, nlay, nday, gas_concs, indices=idxday) + call rad_gas_get_vmr(icall, gaslist(i), state, pbuf, nlay, nday, gas_concs, idxday=idxday) end do end subroutine rrtmgp_set_gases_sw From f7e28725897a4575b9069478993f2cd08d9bb9f5 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Sat, 9 Sep 2023 17:38:45 -0400 Subject: [PATCH 24/53] refactor rrtmgp_set_aer_sw --- src/physics/rrtmgp/radiation.F90 | 204 ++++++++++++--------------- src/physics/rrtmgp/rrtmgp_inputs.F90 | 63 +++++---- 2 files changed, 127 insertions(+), 140 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index f5c468f1c6..018533c6c7 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -525,7 +525,6 @@ subroutine radiation_init(pbuf2d) call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) end if - ! Set the radiation timestep for cosz calculations if requested using ! the adjusted iradsw value from radiation if (use_rad_dt_cosz) then @@ -924,8 +923,8 @@ subroutine radiation_tend( & integer :: itim_old real(r8), pointer :: cld(:,:) ! cloud fraction - real(r8), pointer :: cldfsnow(:,:) => null() ! cloud fraction of just "snow clouds"- whatever they are - real(r8), pointer :: cldfgrau(:,:) => null() ! cloud fraction of just "graupel clouds"- whatever they are + real(r8), pointer :: cldfsnow(:,:) => null() ! cloud fraction of just "snow clouds" + real(r8), pointer :: cldfgrau(:,:) => null() ! cloud fraction of just "graupel clouds" real(r8), pointer :: qrs(:,:) => null() ! shortwave radiative heating rate real(r8), pointer :: qrl(:,:) => null() ! longwave radiative heating rate real(r8), pointer :: fsds(:) ! Surface solar down flux @@ -1126,7 +1125,7 @@ subroutine radiation_tend( & call pbuf_get_field(pbuf, ld_idx, ld) end if - ! initialize (and reset) all the fluxes // sw fluxes only on nday columns + ! Allocate the flux arrays and init to zero. call initialize_rrtmgp_fluxes(nday, nlay+1, nswbands, fsw, do_direct=.true.) call initialize_rrtmgp_fluxes(nday, nlay+1, nswbands, fswc, do_direct=.true.) call initialize_rrtmgp_fluxes(ncol, nlay+1, nlwbands, flw) @@ -1196,9 +1195,11 @@ subroutine radiation_tend( & if (dosw) then - ! - ! "--- SET OPTICAL PROPERTIES & DO SHORTWAVE CALCULATION ---" - ! + + !=============================! + ! SHORTWAVE cloud optics ! + !=============================! + if (oldcldoptics) then call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) @@ -1209,7 +1210,7 @@ subroutine radiation_tend( & case ('mitchell') call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) case default - call endrun('iccldoptics must be one either ebertcurry or mitchell') + call endrun('icecldoptics must be one either ebertcurry or mitchell') end select select case (liqcldoptics) @@ -1288,12 +1289,20 @@ subroutine radiation_tend( & end do end if - ! At this point we have cloud optical properties including snow and graupel, - ! but they need to be re-ordered from the old RRTMG spectral bands to RRTMGP's - c_cld_tau(:,1:ncol,1:pver) = c_cld_tau (rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) - c_cld_tau_w(:,1:ncol,1:pver) = c_cld_tau_w (rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) - c_cld_tau_w_g(:,1:ncol,1:pver) = c_cld_tau_w_g(rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) - c_cld_tau_w_f(:,1:ncol,1:pver) = c_cld_tau_w_f(rrtmg_to_rrtmgp_swbands, 1:ncol, 1:pver) + ! cloud optical properties need to be re-ordered from the RRTMG spectral bands + ! (assumed in the optics datasets) to RRTMGP's + ice_tau(:,:ncol,:) = ice_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + liq_tau(:,:ncol,:) = liq_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + c_cld_tau(:,:ncol,:) = c_cld_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + c_cld_tau_w(:,:ncol,:) = c_cld_tau_w(rrtmg_to_rrtmgp_swbands,:ncol,:) + c_cld_tau_w_g(:,:ncol,:) = c_cld_tau_w_g(rrtmg_to_rrtmgp_swbands,:ncol,:) + c_cld_tau_w_f(:,:ncol,:) = c_cld_tau_w_f(rrtmg_to_rrtmgp_swbands,:ncol,:) + if (cldfsnow_idx > 0) then + snow_tau(:,:ncol,:) = snow_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + end if + if (cldfgrau_idx > 0 .and. graupel_in_rad) then + grau_tau(:,:ncol,:) = grau_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + end if ! cloud_sw : cloud optical properties. call initialize_rrtmgp_cloud_optics_sw(nday, nlay, kdist_sw, cloud_sw) @@ -1303,18 +1312,11 @@ subroutine radiation_tend( & cldfprime, c_cld_tau, c_cld_tau_w, c_cld_tau_w_g, c_cld_tau_w_f, & kdist_sw, cloud_sw) - ! allocate object for aerosol optics - errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber(), & - name='shortwave aerosol optics') - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: aer_sw%alloc_2str: '//trim(errmsg)) - end if - ! ! SHORTWAVE DIAGNOSTICS & OUTPUT ! ! cloud optical depth fields for the visible band - rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) ! should be equal to cloud_sw%tau except ordering + rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) if (cldfsnow_idx > 0) then @@ -1345,16 +1347,18 @@ subroutine radiation_tend( & call radiation_output_cld(lchnk, ncol, rd) end if - !=============================! - ! SHORTWAVE flux calculations ! - !=============================! - - ! initialize object for gas concentrations + ! Initialize object for gas concentrations. errmsg = gas_concs_sw%init(gaslist_lc) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: gas_concs_sw%init: '//trim(errmsg)) end if + ! Allocate object for aerosol optics. + errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber()) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: aer_sw%alloc_2str: '//trim(errmsg)) + end if + ! The climate (icall==0) calculation must occur last. do icall = N_DIAG, 0, -1 if (active_calls(icall)) then @@ -1364,67 +1368,35 @@ subroutine radiation_tend( & icall, state, pbuf, nlay, nday, & idxday, gas_concs_sw) - call aer_rad_props_sw( & ! Get aerosol shortwave optical properties - icall, & ! input - state, & ! input - pbuf, & ! input pointer - nnite, & ! input - idxnite, & ! input - aer_tau, & ! output - aer_tau_w, & ! output - aer_tau_w_g, & ! output - aer_tau_w_f & ! output - ) - ! NOTE: CAM fields are products tau, tau*ssa, tau*ssa*asy, tau*ssa*asy*fsf - ! but RRTMGP is expecting just the values per band. - ! rrtmgp_set_aer_sw does the division and puts values into aer_sw: - ! aer_sw%g = aer_tau_w_g / aer_taw_w - ! aer_sw%ssa = aer_tau_w / aer_tau - ! aer_sw%tau = aer_tau - ! ** As with cloud above, we need to re-order to account for band differences: - - aer_tau(:, :, :) = aer_tau( :, :, rrtmg_to_rrtmgp_swbands) - aer_tau_w(:, :, :) = aer_tau_w( :, :, rrtmg_to_rrtmgp_swbands) - aer_tau_w_g(:, :, :) = aer_tau_w_g(:, :, rrtmg_to_rrtmgp_swbands) - aer_tau_w_f(:, :, :) = aer_tau_w_f(:, :, rrtmg_to_rrtmgp_swbands) + ! Get aerosol shortwave optical properties. The output optics arrays + ! contain an extra top layer set to zero. + call aer_rad_props_sw( & + icall, state, pbuf, nnite, idxnite, & + aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) + + ! aerosol optical properties need to be re-ordered from the RRTMG spectral bands, + ! as assumed in the optics datasets, to the RRTMGP band order. + aer_tau(:,:,:) = aer_tau(:,:,rrtmg_to_rrtmgp_swbands) + aer_tau_w(:,:,:) = aer_tau_w(:,:,rrtmg_to_rrtmgp_swbands) + aer_tau_w_g(:,:,:) = aer_tau_w_g(:,:,rrtmg_to_rrtmgp_swbands) + aer_tau_w_f(:,:,:) = aer_tau_w_f(:,:,rrtmg_to_rrtmgp_swbands) ! Convert from the products to individual properties, ! and only provide them on the daylit points. call rrtmgp_set_aer_sw( & - nswbands, & - nday, & - idxday(1:nday), & ! required to truncate to 1:nday - aer_tau, & - aer_tau_w, & - aer_tau_w_g, & - aer_tau_w_f, & - aer_sw) + nday, idxday, aer_tau, aer_tau_w, aer_tau_w_g, & + aer_tau_w_f, aer_sw) - ! Compute SW fluxes + !=============================! + ! SHORTWAVE flux calculations ! + !=============================! - ! check that optical properties are in bounds: - call clipper(cloud_sw%tau, 0._r8, huge(cloud_sw%tau)) - call clipper(cloud_sw%ssa, 0._r8, 1._r8) - call clipper(cloud_sw%g, -1._r8, 1._r8) - - ! inputs are the daylit columns --> output fluxes therefore also on daylit columns. - errmsg = rte_sw( kdist_sw, & ! input (from init) - gas_concs_sw, & ! input, (from rrtmgp_set_gases_sw) - pmid_day, & ! input, (from rrtmgp_set_state) - t_day, & ! input, (from rrtmgp_set_state) - pint_day, & ! input, (from rrtmgp_set_state) - coszrs_day, & ! input, (from rrtmgp_set_state) - alb_dir, & ! input, (from rrtmgp_set_state) - alb_dif, & ! input, (from rrtmgp_set_state) - cloud_sw, & ! input, (from rrtmgp_set_cloud_sw) - fsw, & ! inout - fswc, & ! inout - aer_props=aer_sw, & ! optional input (from rrtmgp_set_aer_sw) - tsi_scaling=eccf & !< optional input, scaling for irradiance - ) - + errmsg = rte_sw( & + kdist_sw, gas_concs_sw, pmid_day, t_day, pint_day, & + coszrs_day, alb_dir, alb_dif, cloud_sw, fsw, & + fswc, aer_props=aer_sw, tsi_scaling=eccf) if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR code returned by rte_sw: '//trim(errmsg)) + call endrun(sub//': ERROR in rte_sw: '//trim(errmsg)) end if ! ! -- shortwave output -- @@ -1932,7 +1904,6 @@ end subroutine radiation_tend !=============================================================================== - subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) ! Dump shortwave radiation information to history buffer. @@ -1961,7 +1932,7 @@ subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) - call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) ! not sure why ncol instead of pcols, but matches RRTMG version + call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) call outfld('FSNT'//diag(icall), rd%flux_sw_net_top, pcols, lchnk) @@ -2006,7 +1977,6 @@ subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) end subroutine radiation_output_sw - !=============================================================================== subroutine radiation_output_cld(lchnk, ncol, rd) @@ -2681,38 +2651,20 @@ end subroutine coefs_init !========================================================================================= -subroutine reset_fluxes(fluxes) - - use mo_fluxes_byband, only: ty_fluxes_byband - type(ty_fluxes_byband), intent(inout) :: fluxes - - ! Reset broadband fluxes - fluxes%flux_up(:,:) = 0._r8 - fluxes%flux_dn(:,:) = 0._r8 - fluxes%flux_net(:,:) = 0._r8 - if (associated(fluxes%flux_dn_dir)) then - fluxes%flux_dn_dir(:,:) = 0._r8 - end if - - ! Reset band-by-band fluxes - fluxes%bnd_flux_up(:,:,:) = 0._r8 - fluxes%bnd_flux_dn(:,:,:) = 0._r8 - fluxes%bnd_flux_net(:,:,:) = 0._r8 - if (associated(fluxes%bnd_flux_dn_dir)) then - fluxes%bnd_flux_dn_dir(:,:,:) = 0._r8 - end if - -end subroutine reset_fluxes +subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct) + ! Allocate flux arrays and set values to zero. -subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct) - ! This closely follows the E3SM implementation. use mo_fluxes_byband, only: ty_fluxes_byband + + ! Arguments integer, intent(in) :: ncol, nlevels, nbands type(ty_fluxes_byband), intent(inout) :: fluxes logical, intent(in), optional :: do_direct + ! Local variables logical :: do_direct_local + !---------------------------------------------------------------------------- if (present(do_direct)) then do_direct_local = .true. @@ -2720,11 +2672,6 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct) do_direct_local = .false. end if - ! Allocate flux arrays - ! NOTE: fluxes defined at interfaces, so need to either pass nlevels as - ! number of model levels plus one, or allocate as nlevels+1 if nlevels - ! represents number of model levels rather than number of interface levels. - ! Broadband fluxes allocate(fluxes%flux_up(ncol, nlevels)) allocate(fluxes%flux_dn(ncol, nlevels)) @@ -2744,6 +2691,35 @@ end subroutine initialize_rrtmgp_fluxes !========================================================================================= +subroutine reset_fluxes(fluxes) + + ! Reset flux arrays to zero. + + use mo_fluxes_byband, only: ty_fluxes_byband + + type(ty_fluxes_byband), intent(inout) :: fluxes + !---------------------------------------------------------------------------- + + ! Reset broadband fluxes + fluxes%flux_up(:,:) = 0._r8 + fluxes%flux_dn(:,:) = 0._r8 + fluxes%flux_net(:,:) = 0._r8 + if (associated(fluxes%flux_dn_dir)) then + fluxes%flux_dn_dir(:,:) = 0._r8 + end if + + ! Reset band-by-band fluxes + fluxes%bnd_flux_up(:,:,:) = 0._r8 + fluxes%bnd_flux_dn(:,:,:) = 0._r8 + fluxes%bnd_flux_net(:,:,:) = 0._r8 + if (associated(fluxes%bnd_flux_dn_dir)) then + fluxes%bnd_flux_dn_dir(:,:,:) = 0._r8 + end if + +end subroutine reset_fluxes + +!========================================================================================= + subroutine initialize_rrtmgp_cloud_optics_sw(ncol, nlevels, kdist, optics) ! use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp ! module level use mo_optical_props, only: ty_optical_props_2str @@ -2768,6 +2744,7 @@ subroutine initialize_rrtmgp_cloud_optics_sw(ncol, nlevels, kdist, optics) optics%g = 0.0_r8 end subroutine initialize_rrtmgp_cloud_optics_sw +!========================================================================================= subroutine initialize_rrtmgp_cloud_optics_lw(ncol, nlevels, kdist, optics) ! use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp ! module level @@ -2790,6 +2767,7 @@ subroutine initialize_rrtmgp_cloud_optics_lw(ncol, nlevels, kdist, optics) end subroutine initialize_rrtmgp_cloud_optics_lw +!========================================================================================= subroutine free_optics_sw(optics) use mo_optical_props, only: ty_optical_props_2str diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 600b714141..04c878fdc3 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -3,8 +3,9 @@ module rrtmgp_inputs !-------------------------------------------------------------------------------- ! Transform data for state inputs from CAM's data structures to those used by ! RRTMGP. Subset the number of model levels if CAM's top exceeds RRTMGP's -! valid domain. -! +! valid domain. Add an extra layer if CAM's top is below 1 Pa. +! The vertical indexing increases from top to bottom of atmosphere in both +! CAM and RRTMGP arrays. !-------------------------------------------------------------------------------- use shr_kind_mod, only: r8=>shr_kind_r8 @@ -94,7 +95,7 @@ subroutine rrtmgp_set_state( & ! arguments type(physics_state), intent(in) :: state ! CAM physics state type(cam_in_t), intent(in) :: cam_in ! CAM import state - integer, intent(in) :: ncol ! # cols in chunk + integer, intent(in) :: ncol ! # cols in CAM chunk integer, intent(in) :: nlay ! # layers in rrtmgp grid integer, intent(in) :: nday ! # daylight columns integer, intent(in) :: idxday(:) ! chunk indicies of daylight columns @@ -131,7 +132,7 @@ subroutine rrtmgp_set_state( & ! to be consistent with t_sfc. emis_sfc(:,:) = 1._r8 - ! Assume level ordering is the same for both CAM and RRTMGP (top to bottom) + ! Level ordering is the same for both CAM and RRTMGP (top to bottom) t_rad(:,ktoprad:) = state%t(:ncol,ktopcam:) pmid_rad(:,ktoprad:) = state%pmid(:ncol,ktopcam:) pint_rad(:,ktoprad:) = state%pint(:ncol,ktopcam:) @@ -149,7 +150,7 @@ subroutine rrtmgp_set_state( & tref_min = kdist_sw%get_temp_min() tref_max = kdist_sw%get_temp_max() if ( any(t_rad < tref_min) .or. any(t_rad > tref_max) ) then - ! Find out of range value and quit. + ! Report out of range value and quit. do i = 1, ncol do k = 1, nlay if ( t_rad(i,k) < tref_min .or. t_rad(i,k) > tref_max ) then @@ -231,7 +232,7 @@ logical function is_visible(wavenumber) ! wavenumber in inverse cm (cm^-1) real(r8), intent(in) :: wavenumber - ! Threshold between visible and infrared is 0.7 micron, or 14286 cm^-1 + ! Set threshold between visible and infrared to 0.7 micron, or 14286 cm^-1 real(r8), parameter :: visible_wavenumber_threshold = 14286._r8 ! cm^-1 if (wavenumber > visible_wavenumber_threshold) then @@ -558,7 +559,7 @@ subroutine rrtmgp_set_cloud_sw( & real(r8), allocatable :: ssacmcl(:,:,:) real(r8), allocatable :: asmcmcl(:,:,:) - character(len=32) :: sub = 'rrtmgp_set_cloud_sw' + character(len=*), parameter :: sub = 'rrtmgp_set_cloud_sw' character(len=128) :: errmsg real(r8) :: small_val = 1.e-80_r8 real(r8), allocatable :: day_cld_tau(:,:,:) @@ -641,18 +642,25 @@ end subroutine rrtmgp_set_cloud_sw !================================================================================================== subroutine rrtmgp_set_aer_sw( & - nswbands, nday, idxday, aer_tau, aer_tau_w, & + nday, idxday, aer_tau, aer_tau_w, & aer_tau_w_g, aer_tau_w_f, aer_sw) ! Load aerosol SW optical properties into the RRTMGP object. ! - ! *** N.B. *** The input optical arrays from CAM are dimensioned in the vertical - ! as 0:pver. The index 0 is for the extra layer used in the radiation - ! calculation. - - - ! arguments - integer, intent(in) :: nswbands + ! CAM fields are products tau, tau*ssa, tau*ssa*asy, tau*ssa*asy*fsf + ! Fields expected by RRTMGP are computed by + ! aer_sw%tau = aer_tau + ! aer_sw%ssa = aer_tau_w / aer_tau + ! aer_sw%g = aer_tau_w_g / aer_taw_w + ! + ! The input optical arrays from CAM are dimensioned in the vertical + ! as 0:pver. The index 0 is for the extra layer used in the radiation + ! calculation. The index ktopcam assumes the CAM vertical indices are + ! in the range 1:pver, so using this index correctly ignores vertical + ! index 0. If an "extra" layer is used in the calculations, it is + ! provided and set in the RRTMGP aerosol object aer_sw. + + ! Arguments integer, intent(in) :: nday integer, intent(in) :: idxday(:) real(r8), intent(in) :: aer_tau (pcols,0:pver,nswbands) ! extinction optical depth @@ -662,30 +670,31 @@ subroutine rrtmgp_set_aer_sw( & type(ty_optical_props_2str), intent(inout) :: aer_sw ! local variables - integer :: ns - integer :: k, kk integer :: i - integer, dimension(nday) :: day_cols + + ! minimum value for aer_tau_w is the same as used in RRTMG code. + real(r8), parameter :: tiny = 1.e-80_r8 + character(len=32) :: sub = 'rrtmgp_set_aer_sw' character(len=128) :: errmsg !-------------------------------------------------------------------------------- + ! If there is an extra layer in the radiation then this initialization ! will provide default values there. aer_sw%tau = 0.0_r8 aer_sw%ssa = 1.0_r8 aer_sw%g = 0.0_r8 - day_cols = idxday(1:nday) - ! aer_sw is on RAD grid, aer_tau* is on CAM grid ... to make sure they align, use ktop* - ! aer_sw has dimensions of (nday, nlay, nswbands) - aer_sw%tau(1:nday, ktoprad:, :) = max(aer_tau(day_cols, ktopcam:, :), 0._r8) - aer_sw%ssa(1:nday, ktoprad:, :) = merge( aer_tau_w(day_cols, ktopcam:,:)/aer_tau(day_cols, ktopcam:, :), & - 1._r8, aer_tau(day_cols, ktopcam:, :) > 0._r8) - aer_sw%g( 1:nday, ktoprad:, :) = merge( aer_tau_w_g(day_cols, ktopcam:, :) / aer_tau_w(day_cols, ktopcam:, :), & - 0._r8, aer_tau_w(day_cols, ktopcam:, :) > 1.e-80_r8) + do i = 1, nday + ! aer_sw arrays have dimensions of (nday,nlay,nswbands) + aer_sw%tau(i,ktoprad:,:) = max(aer_tau(idxday(i),ktopcam:,:), 0._r8) + aer_sw%ssa(i,ktoprad:,:) = merge(aer_tau_w(idxday(i),ktopcam:,:)/aer_tau(idxday(i),ktopcam:,:), & + 1._r8, aer_tau(idxday(i),ktopcam:,:) > 0._r8) + aer_sw%g(i,ktoprad:,:) = merge(aer_tau_w_g(idxday(i),ktopcam:,:)/aer_tau_w(idxday(i),ktopcam:,:), & + 0._r8, aer_tau_w(idxday(i),ktopcam:,:) > tiny) + end do ! impose limits on the components: - ! aer_sw%tau = max(aer_sw%tau, 0._r) <-- already imposed aer_sw%ssa = min(max(aer_sw%ssa, 0._r8), 1._r8) aer_sw%g = min(max(aer_sw%g, -1._r8), 1._r8) ! by clamping the values here, the validate method should be guaranteed to succeed, From 79196ad0c19946cfd0d54ef0ba9c51510eb2ba4f Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 12 Sep 2023 09:34:31 -0400 Subject: [PATCH 25/53] refactor sw flux calculation --- src/physics/rrtmgp/radconstants.F90 | 6 ++ src/physics/rrtmgp/radiation.F90 | 93 ++++++++++++++++++++++------- 2 files changed, 76 insertions(+), 23 deletions(-) diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index a04cbef23d..9aaca3ad1b 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -26,6 +26,9 @@ module radconstants logical :: wavenumber_boundaries_set = .false. +integer, public, protected :: nswgpts ! # SW gpts +integer, public, protected :: nlwgpts ! # LW gpts + ! These are indices to specific bands for diagnostic output and COSP input. integer, public, protected :: idx_sw_diag = -1 ! band contains 500-nm wave integer, public, protected :: idx_nir_diag = -1 ! band contains 1000-nm wave @@ -88,6 +91,9 @@ subroutine set_wavenumber_bands(kdist_sw, kdist_lw) call endrun(sub//': ERROR: '//trim(errmsg)) end if + nswgpts = kdist_sw%get_ngpt() + nlwgpts = kdist_lw%get_ngpt() + ! SW band bounds in cm^-1 allocate( values(2,nswbands) ) values = kdist_sw%get_band_lims_wavenumber() diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 018533c6c7..3a0caba6d3 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -27,9 +27,10 @@ module radiation use rrtmgp_inputs, only: rrtmgp_inputs_init -use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_nir_diag, idx_uv_diag, & - idx_lw_diag, idx_sw_cloudsim, idx_lw_cloudsim, & - nradgas, gasnamelength, gaslist, set_wavenumber_bands +use radconstants, only: nswbands, nlwbands, nswgpts, nlwgpts, idx_sw_diag, & + idx_nir_diag, idx_uv_diag, idx_lw_diag, idx_sw_cloudsim, & + idx_lw_cloudsim, nradgas, gasnamelength, gaslist, & + set_wavenumber_bands use cloud_rad_props, only: cloud_rad_props_init @@ -875,7 +876,11 @@ subroutine radiation_tend( & use mo_fluxes_byband, only: ty_fluxes_byband ! RRTMGP drivers for flux calculations. - use rrtmgp_driver, only: rte_lw, rte_sw +!++dbg +! use rrtmgp_driver, only: rte_lw, rte_sw + use rrtmgp_driver, only: rte_lw + use mo_rte_sw, only: rte_sw +!--dbg use radheat, only: radheat_tend @@ -1000,13 +1005,17 @@ subroutine radiation_tend( & 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) - ! Aerosol radiative properties **N.B.** These are zero-indexed to be on RADIATION GRID (assumes "extra layer" is being added?) + ! Aerosol radiative properties **N.B.** These are zero-indexed to accomodate an "extra layer". + ! If no extra layer then the 0 index is ignored. 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_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + ! Set vertical indexing in RRTMGP to be the same as CAM (top to bottom). + logical, parameter :: top_at_1 = .true. + ! RRTMGP cloud objects (McICA sampling of cloud optical properties) type(ty_optical_props_1scl) :: cloud_lw type(ty_optical_props_2str) :: cloud_sw @@ -1017,7 +1026,11 @@ subroutine radiation_tend( & type(ty_gas_concs) :: gas_concs_lw type(ty_gas_concs) :: gas_concs_sw - ! RRTMGP aerosol objects + ! Atmosphere optics. This object contains gas optics, aerosol optics, and cloud optics. +! type(ty_optical_props_1scl) :: gas_optics_lw + type(ty_optical_props_2str) :: atm_optics_sw + + ! aerosol optics type(ty_optical_props_1scl) :: aer_lw type(ty_optical_props_2str) :: aer_sw @@ -1031,6 +1044,8 @@ subroutine radiation_tend( & real(r8) :: fnl(pcols,pverp) ! net longwave flux real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux + ! TOA solar flux computed by RRTMGP (on gpts). + real(r8), allocatable :: toa_flux(:,:) ! for COSP real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity @@ -1172,7 +1187,7 @@ subroutine radiation_tend( & if (dosw .or. dolw) then allocate( & - t_sfc(ncol), emis_sfc(nlwbands,ncol), & + 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) ) @@ -1185,7 +1200,7 @@ subroutine radiation_tend( & pint_day, coszrs_day, alb_dir, alb_dif) ! Set TSI for RRTMGP to the value from CAM's solar forcing file. - errmsg = kdist_sw%set_tsi(sol_tsi) + errmsg = kdist_sw%set_tsi(sol_tsi*eccf) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: kdist_sw%set_tsi: '//trim(errmsg)) end if @@ -1312,9 +1327,8 @@ subroutine radiation_tend( & cldfprime, c_cld_tau, c_cld_tau_w, c_cld_tau_w_g, c_cld_tau_w_f, & kdist_sw, cloud_sw) - ! - ! SHORTWAVE DIAGNOSTICS & OUTPUT - ! + ! SW cloud diagnostics & output + ! cloud optical depth fields for the visible band rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) @@ -1353,7 +1367,13 @@ subroutine radiation_tend( & call endrun(sub//': ERROR: gas_concs_sw%init: '//trim(errmsg)) end if - ! Allocate object for aerosol optics. + ! Init and allocate arrays in atm optics object. + errmsg = atm_optics_sw%alloc_2str(nday, nlay, kdist_sw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: gas_optics_sw%alloc_2str: '//trim(errmsg)) + end if + + ! Init and allocate arrays in aerosol optics object. errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber()) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: aer_sw%alloc_2str: '//trim(errmsg)) @@ -1368,8 +1388,15 @@ subroutine radiation_tend( & icall, state, pbuf, nlay, nday, & idxday, gas_concs_sw) - ! Get aerosol shortwave optical properties. The output optics arrays - ! contain an extra top layer set to zero. + ! Init atm_optics_sw with gas optics. Also returns TOA solar flux. + errmsg = kdist_sw%gas_optics( & + pmid_day, pint_day, t_day, gas_concs_sw, atm_optics_sw, & + toa_flux) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: kdist_sw%gas_optics: '//trim(errmsg)) + end if + + ! Get aerosol shortwave optical properties on CAM grid. call aer_rad_props_sw( & icall, state, pbuf, nnite, idxnite, & aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) @@ -1390,17 +1417,37 @@ subroutine radiation_tend( & !=============================! ! SHORTWAVE flux calculations ! !=============================! - - errmsg = rte_sw( & - kdist_sw, gas_concs_sw, pmid_day, t_day, pint_day, & - coszrs_day, alb_dir, alb_dif, cloud_sw, fsw, & - fswc, aer_props=aer_sw, tsi_scaling=eccf) + + ! Aerosols are included in the clear sky calculation. + errmsg = aer_sw%increment(atm_optics_sw) if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in rte_sw: '//trim(errmsg)) + call endrun(sub//': ERROR in aer_sw%increment: '//trim(errmsg)) + end if + + errmsg = rte_sw(& + atm_optics_sw, top_at_1, coszrs_day, toa_flux, & + alb_dir, alb_dif, fswc) + +! errmsg = rte_sw( & +! kdist_sw, gas_concs_sw, pmid_day, t_day, pint_day, & +! coszrs_day, alb_dir, alb_dif, cloud_sw, fsw, & +! fswc, aer_props=aer_sw, tsi_scaling=eccf) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR in clear-sky rte_sw: '//trim(errmsg)) + end if + + ! Add cloud optics for all-sky calculation + errmsg = cloud_sw%increment(atm_optics_sw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR in cloud_sw%increment: '//trim(errmsg)) + end if + + errmsg = rte_sw(& + atm_optics_sw, top_at_1, coszrs_day, toa_flux, & + alb_dir, alb_dif, fsw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR in all-sky rte_sw: '//trim(errmsg)) end if - ! - ! -- shortwave output -- - ! ! Transform RRTMGP outputs to CAM outputs ! - including fsw (W/m2) -> qrs (J/(kgK)) From 7cd5b1a8b7cf9e8bf6ab1011f0a5a469a7d8f6f7 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 13 Sep 2023 09:07:15 -0400 Subject: [PATCH 26/53] refactor setting tsi to fix bug --- src/physics/rrtmgp/radiation.F90 | 92 ++++++++++++-------------------- 1 file changed, 33 insertions(+), 59 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 3a0caba6d3..a8e0d7b9e0 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -586,7 +586,6 @@ subroutine radiation_init(pbuf2d) sampling_seq='rad_lwsw', flag_xyfill=.true.) endif - ! get list of active radiation calls call rad_cnst_get_call_list(active_calls) @@ -876,11 +875,8 @@ subroutine radiation_tend( & use mo_fluxes_byband, only: ty_fluxes_byband ! RRTMGP drivers for flux calculations. -!++dbg -! use rrtmgp_driver, only: rte_lw, rte_sw use rrtmgp_driver, only: rte_lw use mo_rte_sw, only: rte_sw -!--dbg use radheat, only: radheat_tend @@ -1044,8 +1040,10 @@ subroutine radiation_tend( & real(r8) :: fnl(pcols,pverp) ! net longwave flux real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux - ! TOA solar flux computed by RRTMGP (on gpts). + ! TOA solar flux on gpts real(r8), allocatable :: toa_flux(:,:) + ! TSI from RRTMGP data + real(r8) :: tsi_ref ! for COSP real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity @@ -1092,11 +1090,13 @@ subroutine radiation_tend( & if (use_rad_uniform_angle) then do i = 1, ncol - coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, uniform_angle=rad_uniform_angle) + coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, & + uniform_angle=rad_uniform_angle) end do else do i = 1, ncol - coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg) ! if dt_avg /= 0, it triggers using avg coszrs + ! if dt_avg /= 0, it triggers using avg coszrs + coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg) end do end if @@ -1171,8 +1171,8 @@ subroutine radiation_tend( & ! To avoid non-daylit columns ! from having shortwave heating, we should reset here: if (nday == 0) then - qrs(1:ncol,1:pver) = 0 - rd%qrsc(1:ncol,1:pver) = 0 ! this is what gets turned into QRSC in output (probably not needed here.) + qrs(1:ncol,1:pver) = 0._r8 + rd%qrsc(1:ncol,1:pver) = 0._r8 ! this is what gets turned into QRSC in output (probably not needed here.) dosw = .false. end if @@ -1199,12 +1199,6 @@ subroutine radiation_tend( & t_rad, pmid_rad, pint_rad, t_day, pmid_day, & pint_day, coszrs_day, alb_dir, alb_dif) - ! Set TSI for RRTMGP to the value from CAM's solar forcing file. - errmsg = kdist_sw%set_tsi(sol_tsi*eccf) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: kdist_sw%set_tsi: '//trim(errmsg)) - end if - ! Modified cloud fraction accounts for radiatively active snow and/or graupel call modified_cloud_fraction(ncol, cld, cldfsnow, cldfgrau, cldfprime) @@ -1396,6 +1390,10 @@ subroutine radiation_tend( & call endrun(sub//': ERROR: kdist_sw%gas_optics: '//trim(errmsg)) end if + ! Scale the solar source + tsi_ref = sum(toa_flux(1,:)) + toa_flux = toa_flux * sol_tsi * eccf / tsi_ref + ! Get aerosol shortwave optical properties on CAM grid. call aer_rad_props_sw( & icall, state, pbuf, nnite, idxnite, & @@ -1427,11 +1425,6 @@ subroutine radiation_tend( & errmsg = rte_sw(& atm_optics_sw, top_at_1, coszrs_day, toa_flux, & alb_dir, alb_dif, fswc) - -! errmsg = rte_sw( & -! kdist_sw, gas_concs_sw, pmid_day, t_day, pint_day, & -! coszrs_day, alb_dir, alb_dif, cloud_sw, fsw, & -! fswc, aer_props=aer_sw, tsi_scaling=eccf) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR in clear-sky rte_sw: '//trim(errmsg)) end if @@ -1617,8 +1610,6 @@ subroutine radiation_tend( & end if end if ! if (dolw) - ! replaces old "rrtmg_state_destroy" -- deallocates outputs from rrtmgp_set_state() - ! note rd%solin is not being deallocated here, but rd is deallocated after the output stage. deallocate( & t_sfc, emis_sfc, t_rad, pmid_rad, pint_rad, & t_day, pmid_day, pint_day, coszrs_day, alb_dir, & @@ -1627,7 +1618,7 @@ subroutine radiation_tend( & !!! *** BEGIN COSP *** if (docosp) then - ! initialize and calculate emis + emis(:,:) = 0._r8 emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(idx_lw_cloudsim,:ncol,:)) call outfld('EMIS', emis, pcols, lchnk) @@ -2626,42 +2617,25 @@ subroutine coefs_init(coefs_file, available_gases, kdist) totplnk, planck_frac, rayl_lower, rayl_upper, & optimal_angle_fit) else if (allocated(solar_src_quiet)) then - error_msg = kdist%load(available_gases, & - gas_names, & - key_species, & - band2gpt, & - band_lims_wavenum, & - press_ref, & - press_ref_trop, & - temp_ref, & - temp_ref_p, & - temp_ref_t, & - vmr_ref, & - kmajor, & - kminor_lower, & - kminor_upper, & - gas_minor, & - identifier_minor, & - minor_gases_lower, & - minor_gases_upper, & - minor_limits_gpt_lower, & - minor_limits_gpt_upper, & - minor_scales_with_density_lower, & - minor_scales_with_density_upper, & - scaling_gas_lower, & - scaling_gas_upper, & - scale_by_complement_lower, & - scale_by_complement_upper, & - kminor_start_lower, & - kminor_start_upper, & - solar_src_quiet, & - solar_src_facular, & - solar_src_sunspot, & - tsi_default, & - mg_default, & - sb_default, & - rayl_lower, & - rayl_upper) + error_msg = kdist%load( & + available_gases, gas_names, key_species, & + band2gpt, band_lims_wavenum, & + press_ref, press_ref_trop, temp_ref, & + temp_ref_p, temp_ref_t, vmr_ref, & + kmajor, kminor_lower, kminor_upper, & + gas_minor, identifier_minor, & + minor_gases_lower, minor_gases_upper, & + minor_limits_gpt_lower, minor_limits_gpt_upper, & + minor_scales_with_density_lower, & + minor_scales_with_density_upper, & + scaling_gas_lower, scaling_gas_upper, & + scale_by_complement_lower, & + scale_by_complement_upper, & + kminor_start_lower, & + kminor_start_upper, & + solar_src_quiet, solar_src_facular, solar_src_sunspot, & + tsi_default, mg_default, sb_default, & + rayl_lower, rayl_upper) else error_msg = 'must supply either totplnk and planck_frac, or solar_src_[*]' end if From b1806227d680187c7f1d953161bf0df50c4a2072 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 15 Sep 2023 12:33:31 -0400 Subject: [PATCH 27/53] misc cleanup --- src/physics/rrtmg/cloud_rad_props.F90 | 2 +- src/physics/rrtmgp/cloud_rad_props.F90 | 75 ++++++++------- src/physics/rrtmgp/radiation.F90 | 122 ++++++++++++------------- src/physics/rrtmgp/rrtmgp_inputs.F90 | 3 +- 4 files changed, 101 insertions(+), 101 deletions(-) diff --git a/src/physics/rrtmg/cloud_rad_props.F90 b/src/physics/rrtmg/cloud_rad_props.F90 index c629c38e4b..66376fd1d8 100644 --- a/src/physics/rrtmg/cloud_rad_props.F90 +++ b/src/physics/rrtmg/cloud_rad_props.F90 @@ -7,7 +7,7 @@ module cloud_rad_props use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx -use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_lw_diag +use radconstants, only: nswbands, nlwbands, idx_sw_diag use cam_abortutils, only: endrun use rad_constituents, only: iceopticsfile, liqopticsfile use oldcloud, only: oldcloud_lw, old_liq_get_rad_props_lw, old_ice_get_rad_props_lw, oldcloud_init diff --git a/src/physics/rrtmgp/cloud_rad_props.F90 b/src/physics/rrtmgp/cloud_rad_props.F90 index 1581e04d9a..1ba4f200a3 100644 --- a/src/physics/rrtmgp/cloud_rad_props.F90 +++ b/src/physics/rrtmgp/cloud_rad_props.F90 @@ -24,6 +24,8 @@ module cloud_rad_props public :: & cloud_rad_props_init, & + cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols + cloud_rad_props_get_lw, & ! return LW optical props of total bulk aerosols get_ice_optics_sw, & ! return Mitchell SW ice radiative properties ice_cloud_get_rad_props_lw, & ! return Mitchell LW ice radiative properties get_liquid_optics_sw, & ! return Conley SW radiative properties @@ -31,10 +33,8 @@ module cloud_rad_props grau_cloud_get_rad_props_lw, & get_grau_optics_sw, & snow_cloud_get_rad_props_lw, & - get_snow_optics_sw, & - ! NOTE: Are these required, or are they obsolete? - cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols (?) - cloud_rad_props_get_lw ! return LW optical props of total bulk aerosols (?) + get_snow_optics_sw + integer :: nmu, nlambda real(r8), allocatable :: g_mu(:) ! mu samples on grid @@ -51,11 +51,18 @@ module cloud_rad_props real(r8), allocatable :: asm_sw_ice(:,:) real(r8), allocatable :: abs_lw_ice(:,:) -! +! ! indexes into pbuf for optical parameters of MG clouds -! - integer :: i_dei, i_mu, i_lambda, i_iciwp, i_iclwp, i_des, i_icswp - integer :: i_degrau, i_icgrauwp +! + integer :: i_dei=0 + integer :: i_mu=0 + integer :: i_lambda=0 + integer :: i_iciwp=0 + integer :: i_iclwp=0 + integer :: i_des=0 + integer :: i_icswp=0 + integer :: i_degrau=0 + integer :: i_icgrauwp=0 ! indexes into constituents for old optics integer :: & @@ -80,8 +87,8 @@ subroutine cloud_rad_props_init() use slingo, only: slingo_rad_props_init use ebert_curry, only: ec_rad_props_init, scalefactor - character(len=256) :: liquidfile - character(len=256) :: icefile + character(len=256) :: liquidfile + character(len=256) :: icefile character(len=256) :: locfn integer :: ncid, dimid, f_nlwbands, f_nswbands, ierr @@ -96,7 +103,7 @@ subroutine cloud_rad_props_init() integer :: err - liquidfile = liqopticsfile + liquidfile = liqopticsfile icefile = iceopticsfile call slingo_rad_props_init @@ -143,12 +150,12 @@ subroutine cloud_rad_props_init() call mpibcast(nlambda, 1, mpiint, 0, mpicom, ierr) #endif - if (.not.allocated(g_mu)) allocate(g_mu(nmu)) - if (.not.allocated(g_lambda)) allocate(g_lambda(nmu,nlambda)) - if (.not.allocated(ext_sw_liq)) allocate(ext_sw_liq(nmu,nlambda,nswbands) ) - if (.not.allocated(ssa_sw_liq)) allocate(ssa_sw_liq(nmu,nlambda,nswbands)) - if (.not.allocated(asm_sw_liq)) allocate(asm_sw_liq(nmu,nlambda,nswbands)) - if (.not.allocated(abs_lw_liq)) allocate(abs_lw_liq(nmu,nlambda,nlwbands)) + allocate(g_mu(nmu)) + allocate(g_lambda(nmu,nlambda)) + allocate(ext_sw_liq(nmu,nlambda,nswbands) ) + allocate(ssa_sw_liq(nmu,nlambda,nswbands)) + allocate(asm_sw_liq(nmu,nlambda,nswbands)) + allocate(abs_lw_liq(nmu,nlambda,nlwbands)) if (masterproc) then call handle_ncerr( nf90_inq_varid(ncid, 'mu', mu_id),& @@ -193,8 +200,8 @@ subroutine cloud_rad_props_init() call mpibcast(abs_lw_liq, nmu*nlambda*nlwbands, mpir8, 0, mpicom, ierr) #endif ! I forgot to convert kext from m^2/Volume to m^2/Kg - ext_sw_liq = ext_sw_liq / 0.9970449e3_r8 - abs_lw_liq = abs_lw_liq / 0.9970449e3_r8 + ext_sw_liq = ext_sw_liq / 0.9970449e3_r8 + abs_lw_liq = abs_lw_liq / 0.9970449e3_r8 ! read ice cloud optics if (masterproc) then @@ -221,11 +228,11 @@ subroutine cloud_rad_props_init() ! call mpibcast(nlwbands, 1, mpiint, 0, mpicom, ierr) #endif - if (.not.allocated(g_d_eff)) allocate(g_d_eff(n_g_d)) - if (.not.allocated(ext_sw_ice)) allocate(ext_sw_ice(n_g_d,nswbands)) - if (.not.allocated(ssa_sw_ice)) allocate(ssa_sw_ice(n_g_d,nswbands)) - if (.not.allocated(asm_sw_ice)) allocate(asm_sw_ice(n_g_d,nswbands)) - if (.not.allocated(abs_lw_ice)) allocate(abs_lw_ice(n_g_d,nlwbands)) + allocate(g_d_eff(n_g_d)) + allocate(ext_sw_ice(n_g_d,nswbands)) + allocate(ssa_sw_ice(n_g_d,nswbands)) + allocate(asm_sw_ice(n_g_d,nswbands)) + allocate(abs_lw_ice(n_g_d,nlwbands)) if (masterproc) then call handle_ncerr( nf90_inq_varid(ncid, 'd_eff', d_id),& @@ -280,7 +287,7 @@ subroutine cloud_rad_props_get_sw(state, pbuf, & tau, tau_w, tau_w_g, tau_w_f,& diagnosticindex, oldliq, oldice) -! return totaled (across all species) layer tau, omega, g, f +! return totaled (across all species) layer tau, omega, g, f ! for all spectral interval for aerosols affecting the climate ! Arguments @@ -355,7 +362,7 @@ end subroutine cloud_rad_props_get_sw subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldliq, oldice, oldcloud) ! Purpose: Compute cloud longwave absorption optical depth -! cloud_rad_props_get_lw() is called by radlw() +! cloud_rad_props_get_lw() is called by radlw() ! Arguments type(physics_state), intent(in) :: state @@ -385,7 +392,7 @@ subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldl ncol = state%ncol lchnk = state%lchnk - ! compute optical depths cld_absod + ! compute optical depths cld_absod cld_abs_od = 0._r8 if(present(oldcloud))then @@ -418,8 +425,8 @@ subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldl else call ice_cloud_get_rad_props_lw(state, pbuf, ice_tau_abs_od) endif - - cld_abs_od(:,1:ncol,:) = liq_tau_abs_od(:,1:ncol,:) + ice_tau_abs_od(:,1:ncol,:) + + cld_abs_od(:,1:ncol,:) = liq_tau_abs_od(:,1:ncol,:) + ice_tau_abs_od(:,1:ncol,:) end subroutine cloud_rad_props_get_lw @@ -444,7 +451,7 @@ subroutine get_snow_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) call interpolate_ice_optics_sw(state%ncol, icswpth, des, tau, tau_w, & tau_w_g, tau_w_f) -end subroutine get_snow_optics_sw +end subroutine get_snow_optics_sw !============================================================================== @@ -474,7 +481,7 @@ subroutine get_grau_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) do k = 1, pver if (tau(idx_sw_diag,i,k).gt.100._r8) then write(iulog,*) 'WARNING: SW Graupel Tau > 100 (i,k,icgrauwpth,degrau,tau):' - write(iulog,*) i,k,icgrauwpth(i,k), degrau(i,k), tau(idx_sw_diag,i,k) + write(iulog,*) i,k,icgrauwpth(i,k), degrau(i,k), tau(idx_sw_diag,i,k) end if enddo enddo @@ -483,7 +490,7 @@ subroutine get_grau_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) call endrun('ERROR: Get_grau_optics_sw called when graupel properties not supported') end if -end subroutine get_grau_optics_sw +end subroutine get_grau_optics_sw !============================================================================== ! Private methods @@ -583,7 +590,7 @@ subroutine get_liquid_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) call pbuf_get_field(pbuf, i_lambda, lamc) call pbuf_get_field(pbuf, i_mu, pgam) call pbuf_get_field(pbuf, i_iclwp, iclwpth) - + do k = 1,pver do i = 1,ncol if(lamc(i,k) > 0._r8) then ! This seems to be clue from microphysics of no cloud @@ -662,7 +669,7 @@ subroutine grau_cloud_get_rad_props_lw(state, pbuf, abs_od) ! This does the same thing as ice_cloud_get_rad_props_lw, except with a ! different water path and effective diameter. - if((i_icgrauwp > 0) .and. (i_degrau > 0)) then + if((i_icgrauwp > 0) .and. (i_degrau > 0)) then call pbuf_get_field(pbuf, i_icgrauwp, icgrauwpth) call pbuf_get_field(pbuf, i_degrau, degrau) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index a8e0d7b9e0..e0d074e904 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -55,6 +55,9 @@ module radiation use mo_gas_concentrations, only: ty_gas_concs use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp +use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str +use mo_fluxes_byband, only: ty_fluxes_byband + use string_utils, only: to_lower use cam_abortutils, only: endrun @@ -102,9 +105,9 @@ module radiation real(r8) :: fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa real(r8) :: fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns - real(r8) :: fsn200(pcols) ! fns interpolated to 200 mb - real(r8) :: fsn200c(pcols) ! fcns interpolated to 200 mb - real(r8) :: fsnr(pcols) ! fns interpolated to tropopause + real(r8) :: fsn200(pcols) ! Net SW flux interpolated to 200 mb + real(r8) :: fsn200c(pcols) ! Net clear-sky SW flux interpolated to 200 mb + real(r8) :: fsnr(pcols) ! Net SW flux interpolated to tropopause real(r8) :: flux_sw_up(pcols,pverp) ! upward shortwave flux on interfaces real(r8) :: flux_sw_clr_up(pcols,pverp) ! upward shortwave clearsky flux @@ -507,7 +510,8 @@ subroutine radiation_init(pbuf2d) call coefs_init(coefs_sw_file, available_gases, kdist_sw) call coefs_init(coefs_lw_file, available_gases, kdist_lw) - ! Set the sw/lw band boundaries in radconstants + ! Set the sw/lw band boundaries in radconstants. Also sets + ! indicies of specific bands for diagnostic output and COSP input. call set_wavenumber_bands(kdist_sw, kdist_lw) ! The spectral band boundaries need to be set before this init is called. @@ -870,10 +874,6 @@ subroutine radiation_tend( & 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 mo_optical_props, only: ty_optical_props, ty_optical_props_2str, ty_optical_props_1scl - - use mo_fluxes_byband, only: ty_fluxes_byband - ! RRTMGP drivers for flux calculations. use rrtmgp_driver, only: rte_lw use mo_rte_sw, only: rte_sw @@ -1035,14 +1035,15 @@ subroutine radiation_tend( & type(ty_fluxes_byband) :: fsw, fswc type(ty_fluxes_byband) :: flw, flwc + ! Arrays for output diagnostics on CAM grid. real(r8) :: fns(pcols,pverp) ! net shortwave flux real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux real(r8) :: fnl(pcols,pverp) ! net longwave flux real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux - ! TOA solar flux on gpts + ! TOA solar flux on RRTMGP g-points real(r8), allocatable :: toa_flux(:,:) - ! TSI from RRTMGP data + ! TSI from RRTMGP data (from sum over g-point representation) real(r8) :: tsi_ref ! for COSP @@ -1199,15 +1200,18 @@ subroutine radiation_tend( & t_rad, pmid_rad, pint_rad, t_day, pmid_day, & pint_day, coszrs_day, alb_dir, alb_dif) + ! Output the mass per layer, and total column burdens for gas and aerosol + ! constituents in the climate list. + call rad_cnst_out(0, state, pbuf) + ! Modified cloud fraction accounts for radiatively active snow and/or graupel call modified_cloud_fraction(ncol, cld, cldfsnow, cldfgrau, cldfprime) - - if (dosw) then + !========================! + ! SHORTWAVE calculations ! + !========================! - !=============================! - ! SHORTWAVE cloud optics ! - !=============================! + if (dosw) then if (oldcldoptics) then call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) @@ -1368,6 +1372,7 @@ subroutine radiation_tend( & end if ! Init and allocate arrays in aerosol optics object. + errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber()) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: aer_sw%alloc_2str: '//trim(errmsg)) @@ -1382,7 +1387,8 @@ subroutine radiation_tend( & icall, state, pbuf, nlay, nday, & idxday, gas_concs_sw) - ! Init atm_optics_sw with gas optics. Also returns TOA solar flux. + ! Compute the gas optics (stored in atm_optics_sw). + ! toa_flux is the reference solar source from RRTMGP data. errmsg = kdist_sw%gas_optics( & pmid_day, pint_day, t_day, gas_concs_sw, atm_optics_sw, & toa_flux) @@ -1412,16 +1418,13 @@ subroutine radiation_tend( & nday, idxday, aer_tau, aer_tau_w, aer_tau_w_g, & aer_tau_w_f, aer_sw) - !=============================! - ! SHORTWAVE flux calculations ! - !=============================! - - ! Aerosols are included in the clear sky calculation. + ! Increment the gas optics (in atm_optics_sw) by the aerosol optics in aer_sw. errmsg = aer_sw%increment(atm_optics_sw) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR in aer_sw%increment: '//trim(errmsg)) end if + ! Compute clear-sky fluxes. errmsg = rte_sw(& atm_optics_sw, top_at_1, coszrs_day, toa_flux, & alb_dir, alb_dif, fswc) @@ -1429,12 +1432,13 @@ subroutine radiation_tend( & call endrun(sub//': ERROR in clear-sky rte_sw: '//trim(errmsg)) end if - ! Add cloud optics for all-sky calculation + ! Increment the aerosol+gas optics (in atm_optics_sw) by the cloud optics in cloud_sw. errmsg = cloud_sw%increment(atm_optics_sw) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR in cloud_sw%increment: '//trim(errmsg)) end if + ! Compute all-sky fluxes. errmsg = rte_sw(& atm_optics_sw, top_at_1, coszrs_day, toa_flux, & alb_dir, alb_dif, fsw) @@ -1442,8 +1446,7 @@ subroutine radiation_tend( & call endrun(sub//': ERROR in all-sky rte_sw: '//trim(errmsg)) end if - ! Transform RRTMGP outputs to CAM outputs - ! - including fsw (W/m2) -> qrs (J/(kgK)) + ! Transform RRTMGP outputs to CAM outputs and compute heating rates. call set_sw_diags() if (write_output) then @@ -1459,15 +1462,12 @@ subroutine radiation_tend( & end if end if ! if (dosw) - ! Output aerosol mmr - ! This happens between SW and LW (Why?) - call rad_cnst_out(0, state, pbuf) - - !============================! - ! LONGWAVE flux calculations ! - !============================! + !=======================! + ! LONGWAVE calculations ! + !=======================! if (dolw) then + if (oldcldoptics) then call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) else @@ -1477,7 +1477,7 @@ subroutine radiation_tend( & case ('mitchell') call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) case default - call endrun('ERROR: iccldoptics must be one either ebertcurry or mitchell') + call endrun('ERROR: icecldoptics must be one either ebertcurry or mitchell') end select select case (liqcldoptics) @@ -1490,9 +1490,9 @@ subroutine radiation_tend( & end select cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) + end if - cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) if (cldfsnow_idx > 0) then ! add in snow call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) @@ -1509,6 +1509,7 @@ subroutine radiation_tend( & else c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) end if + if (cldfgrau_idx > 0 .and. graupel_in_rad) then ! add in graupel call grau_cloud_get_rad_props_lw(state, pbuf, grau_lw_abs) @@ -1527,14 +1528,8 @@ subroutine radiation_tend( & ! cloud_lw : cloud optical properties. call initialize_rrtmgp_cloud_optics_lw(ncol, nlay, kdist_lw, cloud_lw) - call rrtmgp_set_cloud_lw( & ! Sets the LW optical depth (tau) that is passed to RRTMGP - state, & ! input (%ncol, %pmid [top-to-bottom]) - nlwbands, & ! input - cldfprime, & ! input Ordered top-to-bottom - c_cld_lw_abs, & ! input Ordered top-to-bottom - kdist_lw, & ! input (%get_ngpt, and whole object passed to mcica) - cloud_lw & ! inout (%tau is set, and returned bottom-to-top) - ) + call rrtmgp_set_cloud_lw(state, nlwbands, cldfprime, c_cld_lw_abs, kdist_lw, & + cloud_lw) ! initialize/allocate object for aerosol optics errmsg = aer_lw%alloc_1scl(ncol, & @@ -1615,8 +1610,10 @@ subroutine radiation_tend( & t_day, pmid_day, pint_day, coszrs_day, alb_dir, & alb_dif) + !================! + ! COSP simulator ! + !================! - !!! *** BEGIN COSP *** if (docosp) then emis(:,:) = 0._r8 @@ -1659,8 +1656,7 @@ subroutine radiation_tend( & snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) cosp_cnt(lchnk) = 0 end if - end if - !!! *** END COSP *** + end if ! docosp else ! --> radiative flux calculations not updated ! convert radiative heating rates from Q*dp to Q for energy conservation @@ -1713,8 +1709,11 @@ subroutine radiation_tend( & end if if (.not. present(rd_out)) then + deallocate(rd%fsdn, rd%fsdnc, rd%fsup, rd%fsupc, & + rd%fldn, rd%fldnc, rd%flup, rd%flupc ) deallocate(rd) end if + call free_optics_sw(atm_optics_sw) call free_optics_sw(cloud_sw) call free_optics_sw(aer_sw) call free_fluxes(fsw) @@ -1731,10 +1730,9 @@ subroutine radiation_tend( & subroutine set_sw_diags() - ! Transform RRTMGP output for CAM - ! Uses the fluxes that come out of RRTMGP. - - ! Expects fluxes on day columns, and expands to full columns. + ! Transform RRTMGP output for CAM and compute heating rates. + ! SW fluxes from RRTMGP are on daylight columns only, so expand to + ! full chunks for output to CAM history. integer :: i real(r8), dimension(size(fsw%bnd_flux_dn,1), & @@ -1742,7 +1740,7 @@ subroutine set_sw_diags() size(fsw%bnd_flux_dn,3)) :: flux_dn_diffuse !------------------------------------------------------------------------- - ! Initializing these arrays to 0.0 provides fill in the night columns: + ! Initialize to provide 0.0 values for night columns. fns = 0._r8 ! net sw flux fcns = 0._r8 ! net sw clearsky flux fsds = 0._r8 ! downward sw flux at surface @@ -2676,8 +2674,6 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct) ! Allocate flux arrays and set values to zero. - use mo_fluxes_byband, only: ty_fluxes_byband - ! Arguments integer, intent(in) :: ncol, nlevels, nbands type(ty_fluxes_byband), intent(inout) :: fluxes @@ -2716,8 +2712,6 @@ subroutine reset_fluxes(fluxes) ! Reset flux arrays to zero. - use mo_fluxes_byband, only: ty_fluxes_byband - type(ty_fluxes_byband), intent(inout) :: fluxes !---------------------------------------------------------------------------- @@ -2742,20 +2736,15 @@ end subroutine reset_fluxes !========================================================================================= subroutine initialize_rrtmgp_cloud_optics_sw(ncol, nlevels, kdist, optics) - ! use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp ! module level - use mo_optical_props, only: ty_optical_props_2str integer, intent(in) :: ncol, nlevels type(ty_gas_optics_rrtmgp), intent(in) :: kdist type(ty_optical_props_2str), intent(out) :: optics - integer :: ngpt character(len=128) :: errmsg character(len=128) :: sub = 'initialize_rrtmgp_cloud_optics_sw' - ! ngpt = kdist%get_ngpt() - - errmsg = optics%alloc_2str(ncol, nlevels, kdist, name='shortwave cloud optics') + errmsg = optics%alloc_2str(ncol, nlevels, kdist) if (len_trim(errmsg) > 0) then call endrun(trim(sub)//': ERROR: optics%alloc_2str: '//trim(errmsg)) end if @@ -2768,8 +2757,6 @@ end subroutine initialize_rrtmgp_cloud_optics_sw !========================================================================================= subroutine initialize_rrtmgp_cloud_optics_lw(ncol, nlevels, kdist, optics) - ! use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp ! module level - use mo_optical_props, only: ty_optical_props_1scl integer, intent(in) :: ncol, nlevels type(ty_gas_optics_rrtmgp), intent(in) :: kdist @@ -2782,7 +2769,7 @@ subroutine initialize_rrtmgp_cloud_optics_lw(ncol, nlevels, kdist, optics) ngpt = kdist%get_ngpt() errmsg =optics%alloc_1scl(ncol, nlevels, kdist, name='longwave cloud optics') if (len_trim(errmsg) > 0) then - call endrun(trim(sub)//': ERROR: optics%init_1scalar: '//trim(errmsg)) + call endrun(trim(sub)//': ERROR: optics%alloc_1scalar: '//trim(errmsg)) end if optics%tau(:ncol, :nlevels, :ngpt) = 0.0 @@ -2791,26 +2778,31 @@ end subroutine initialize_rrtmgp_cloud_optics_lw !========================================================================================= subroutine free_optics_sw(optics) - use mo_optical_props, only: ty_optical_props_2str + type(ty_optical_props_2str), intent(inout) :: optics + if (allocated(optics%tau)) deallocate(optics%tau) if (allocated(optics%ssa)) deallocate(optics%ssa) if (allocated(optics%g)) deallocate(optics%g) call optics%finalize() end subroutine free_optics_sw +!========================================================================================= subroutine free_optics_lw(optics) - use mo_optical_props, only: ty_optical_props_1scl + type(ty_optical_props_1scl), intent(inout) :: optics + if (allocated(optics%tau)) deallocate(optics%tau) call optics%finalize() end subroutine free_optics_lw +!========================================================================================= subroutine free_fluxes(fluxes) - use mo_fluxes_byband, only: ty_fluxes_byband + type(ty_fluxes_byband), intent(inout) :: fluxes + if (associated(fluxes%flux_up)) deallocate(fluxes%flux_up) if (associated(fluxes%flux_dn)) deallocate(fluxes%flux_dn) if (associated(fluxes%flux_net)) deallocate(fluxes%flux_net) diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 04c878fdc3..f1dbb659e2 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -1,7 +1,7 @@ module rrtmgp_inputs !-------------------------------------------------------------------------------- -! Transform data for state inputs from CAM's data structures to those used by +! Transform data for inputs from CAM's data structures to those used by ! RRTMGP. Subset the number of model levels if CAM's top exceeds RRTMGP's ! valid domain. Add an extra layer if CAM's top is below 1 Pa. ! The vertical indexing increases from top to bottom of atmosphere in both @@ -80,6 +80,7 @@ subroutine rrtmgp_inputs_init(ktcam, ktrad) ktopcam = ktcam ktoprad = ktrad + ! Initialize the module data containing the SW band boundaries. call get_sw_spectral_boundaries(sw_low_bounds, sw_high_bounds, 'cm^-1') end subroutine rrtmgp_inputs_init From afbeae33a1af0d5b17c394c734b0c696e823a983 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 15 Sep 2023 12:51:47 -0400 Subject: [PATCH 28/53] move files shared by rrtmg and rrtmgp to physics/cam --- .../{rrtmgp => cam}/cloud_rad_props.F90 | 0 src/physics/{rrtmgp => cam}/ebert_curry.F90 | 0 src/physics/{rrtmgp => cam}/oldcloud.F90 | 0 src/physics/{rrtmgp => cam}/slingo.F90 | 0 src/physics/rrtmg/cloud_rad_props.F90 | 849 ------------------ src/physics/rrtmg/ebert_curry.F90 | 408 --------- src/physics/rrtmg/oldcloud.F90 | 643 ------------- src/physics/rrtmg/slingo.F90 | 409 --------- 8 files changed, 2309 deletions(-) rename src/physics/{rrtmgp => cam}/cloud_rad_props.F90 (100%) rename src/physics/{rrtmgp => cam}/ebert_curry.F90 (100%) rename src/physics/{rrtmgp => cam}/oldcloud.F90 (100%) rename src/physics/{rrtmgp => cam}/slingo.F90 (100%) delete mode 100644 src/physics/rrtmg/cloud_rad_props.F90 delete mode 100644 src/physics/rrtmg/ebert_curry.F90 delete mode 100644 src/physics/rrtmg/oldcloud.F90 delete mode 100644 src/physics/rrtmg/slingo.F90 diff --git a/src/physics/rrtmgp/cloud_rad_props.F90 b/src/physics/cam/cloud_rad_props.F90 similarity index 100% rename from src/physics/rrtmgp/cloud_rad_props.F90 rename to src/physics/cam/cloud_rad_props.F90 diff --git a/src/physics/rrtmgp/ebert_curry.F90 b/src/physics/cam/ebert_curry.F90 similarity index 100% rename from src/physics/rrtmgp/ebert_curry.F90 rename to src/physics/cam/ebert_curry.F90 diff --git a/src/physics/rrtmgp/oldcloud.F90 b/src/physics/cam/oldcloud.F90 similarity index 100% rename from src/physics/rrtmgp/oldcloud.F90 rename to src/physics/cam/oldcloud.F90 diff --git a/src/physics/rrtmgp/slingo.F90 b/src/physics/cam/slingo.F90 similarity index 100% rename from src/physics/rrtmgp/slingo.F90 rename to src/physics/cam/slingo.F90 diff --git a/src/physics/rrtmg/cloud_rad_props.F90 b/src/physics/rrtmg/cloud_rad_props.F90 deleted file mode 100644 index 66376fd1d8..0000000000 --- a/src/physics/rrtmg/cloud_rad_props.F90 +++ /dev/null @@ -1,849 +0,0 @@ -module cloud_rad_props - -!------------------------------------------------------------------------------------------------ -!------------------------------------------------------------------------------------------------ - -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pcols, pver, pverp -use physics_types, only: physics_state -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx -use radconstants, only: nswbands, nlwbands, idx_sw_diag -use cam_abortutils, only: endrun -use rad_constituents, only: iceopticsfile, liqopticsfile -use oldcloud, only: oldcloud_lw, old_liq_get_rad_props_lw, old_ice_get_rad_props_lw, oldcloud_init - -use ebert_curry, only: scalefactor -use cam_logfile, only: iulog - -use interpolate_data, only: interp_type, lininterp_init, lininterp, & - extrap_method_bndry, lininterp_finish - -implicit none -private -save - -public :: & - cloud_rad_props_init, & - cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols - cloud_rad_props_get_lw, & ! return LW optical props of total bulk aerosols - get_ice_optics_sw, & ! return Mitchell SW ice radiative properties - ice_cloud_get_rad_props_lw, & ! Mitchell LW ice rad props - get_liquid_optics_sw, & ! return Conley SW rad props - liquid_cloud_get_rad_props_lw, & ! return Conley LW rad props - grau_cloud_get_rad_props_lw, & - get_grau_optics_sw, & - snow_cloud_get_rad_props_lw, & - get_snow_optics_sw - - -integer :: nmu, nlambda -real(r8), allocatable :: g_mu(:) ! mu samples on grid -real(r8), allocatable :: g_lambda(:,:) ! lambda scale samples on grid -real(r8), allocatable :: ext_sw_liq(:,:,:) -real(r8), allocatable :: ssa_sw_liq(:,:,:) -real(r8), allocatable :: asm_sw_liq(:,:,:) -real(r8), allocatable :: abs_lw_liq(:,:,:) - -integer :: n_g_d -real(r8), allocatable :: g_d_eff(:) ! radiative effective diameter samples on grid -real(r8), allocatable :: ext_sw_ice(:,:) -real(r8), allocatable :: ssa_sw_ice(:,:) -real(r8), allocatable :: asm_sw_ice(:,:) -real(r8), allocatable :: abs_lw_ice(:,:) - -! -! indexes into pbuf for optical parameters of MG clouds -! - integer :: i_dei=0 - integer :: i_mu=0 - integer :: i_lambda=0 - integer :: i_iciwp=0 - integer :: i_iclwp=0 - integer :: i_des=0 - integer :: i_icswp=0 - integer :: i_degrau=0 - integer :: i_icgrauwp=0 - -! indexes into constituents for old optics - integer :: & - ixcldice, & ! cloud ice water index - ixcldliq ! cloud liquid water index - - -!============================================================================== -contains -!============================================================================== - -subroutine cloud_rad_props_init() - - use netcdf - use spmd_utils, only: masterproc - use ioFileMod, only: getfil - use error_messages, only: handle_ncerr -#if ( defined SPMD ) - use mpishorthand -#endif - use constituents, only: cnst_get_ind - use slingo, only: slingo_rad_props_init - use ebert_curry, only: ec_rad_props_init, scalefactor - - character(len=256) :: liquidfile - character(len=256) :: icefile - character(len=256) :: locfn - - integer :: ncid, dimid, f_nlwbands, f_nswbands, ierr - integer :: vdimids(NF90_MAX_VAR_DIMS), ndims, templen - ! liquid clouds - integer :: mudimid, lambdadimid - integer :: mu_id, lambda_id, ext_sw_liq_id, ssa_sw_liq_id, asm_sw_liq_id, abs_lw_liq_id - - ! ice clouds - integer :: d_dimid ! diameters - integer :: d_id, ext_sw_ice_id, ssa_sw_ice_id, asm_sw_ice_id, abs_lw_ice_id - - integer :: err - - liquidfile = liqopticsfile - icefile = iceopticsfile - - call slingo_rad_props_init - call ec_rad_props_init - call oldcloud_init - - i_dei = pbuf_get_index('DEI',errcode=err) - i_mu = pbuf_get_index('MU',errcode=err) - i_lambda = pbuf_get_index('LAMBDAC',errcode=err) - i_iciwp = pbuf_get_index('ICIWP',errcode=err) - i_iclwp = pbuf_get_index('ICLWP',errcode=err) - i_des = pbuf_get_index('DES',errcode=err) - i_icswp = pbuf_get_index('ICSWP',errcode=err) - i_icgrauwp = pbuf_get_index('ICGRAUWP',errcode=err) ! Available when using MG3 - i_degrau = pbuf_get_index('DEGRAU',errcode=err) ! Available when using MG3 - - ! old optics - call cnst_get_ind('CLDICE', ixcldice) - call cnst_get_ind('CLDLIQ', ixcldliq) - - ! read liquid cloud optics - if(masterproc) then - call getfil( trim(liquidfile), locfn, 0) - call handle_ncerr( nf90_open(locfn, NF90_NOWRITE, ncid), 'liquid optics file missing') - write(iulog,*)' reading liquid cloud optics from file ',locfn - - 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') - - 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') - - 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') - - call handle_ncerr(nf90_inq_dimid( ncid, 'lambda_scale', lambdadimid), 'getting lambda dim') - call handle_ncerr(nf90_inquire_dimension( ncid, lambdadimid, len=nlambda), 'getting n lambda samples') - endif ! if (masterproc) - -#if ( defined SPMD ) - call mpibcast(nmu, 1, mpiint, 0, mpicom, ierr) - call mpibcast(nlambda, 1, mpiint, 0, mpicom, ierr) -#endif - - allocate(g_mu(nmu)) - allocate(g_lambda(nmu,nlambda)) - allocate(ext_sw_liq(nmu,nlambda,nswbands) ) - allocate(ssa_sw_liq(nmu,nlambda,nswbands)) - allocate(asm_sw_liq(nmu,nlambda,nswbands)) - allocate(abs_lw_liq(nmu,nlambda,nlwbands)) - - if(masterproc) then - call handle_ncerr( nf90_inq_varid(ncid, 'mu', mu_id),& - 'cloud optics mu get') - call handle_ncerr( nf90_get_var(ncid, mu_id, g_mu),& - 'read cloud optics mu values') - - call handle_ncerr( nf90_inq_varid(ncid, 'lambda', lambda_id),& - 'cloud optics lambda get') - call handle_ncerr( nf90_get_var(ncid, lambda_id, g_lambda),& - 'read cloud optics lambda values') - - call handle_ncerr( nf90_inq_varid(ncid, 'k_ext_sw', ext_sw_liq_id),& - 'cloud optics ext_sw_liq get') - call handle_ncerr( nf90_get_var(ncid, ext_sw_liq_id, ext_sw_liq),& - 'read cloud optics ext_sw_liq values') - - call handle_ncerr( nf90_inq_varid(ncid, 'ssa_sw', ssa_sw_liq_id),& - 'cloud optics ssa_sw_liq get') - call handle_ncerr( nf90_get_var(ncid, ssa_sw_liq_id, ssa_sw_liq),& - 'read cloud optics ssa_sw_liq values') - - call handle_ncerr( nf90_inq_varid(ncid, 'asm_sw', asm_sw_liq_id),& - 'cloud optics asm_sw_liq get') - call handle_ncerr( nf90_get_var(ncid, asm_sw_liq_id, asm_sw_liq),& - 'read cloud optics asm_sw_liq values') - - call handle_ncerr( nf90_inq_varid(ncid, 'k_abs_lw', abs_lw_liq_id),& - 'cloud optics abs_lw_liq get') - call handle_ncerr( nf90_get_var(ncid, abs_lw_liq_id, abs_lw_liq),& - 'read cloud optics abs_lw_liq values') - - call handle_ncerr( nf90_close(ncid), 'liquid optics file missing') - endif ! if masterproc - -#if ( defined SPMD ) - call mpibcast(g_mu, nmu, mpir8, 0, mpicom, ierr) - call mpibcast(g_lambda, nmu*nlambda, mpir8, 0, mpicom, ierr) - call mpibcast(ext_sw_liq, nmu*nlambda*nswbands, mpir8, 0, mpicom, ierr) - call mpibcast(ssa_sw_liq, nmu*nlambda*nswbands, mpir8, 0, mpicom, ierr) - call mpibcast(asm_sw_liq, nmu*nlambda*nswbands, mpir8, 0, mpicom, ierr) - call mpibcast(abs_lw_liq, nmu*nlambda*nlwbands, mpir8, 0, mpicom, ierr) -#endif - ! I forgot to convert kext from m^2/Volume to m^2/Kg - ext_sw_liq = ext_sw_liq / 0.9970449e3_r8 - abs_lw_liq = abs_lw_liq / 0.9970449e3_r8 - - ! read ice cloud optics - if(masterproc) then - call getfil( trim(icefile), locfn, 0) - call handle_ncerr( nf90_open(locfn, NF90_NOWRITE, ncid), 'ice optics file missing') - write(iulog,*)' reading ice cloud optics from file ',locfn - - 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') - - 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') - - 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') - - endif ! if (masterproc) - -#if ( defined SPMD ) - call mpibcast(n_g_d, 1, mpiint, 0, mpicom, ierr) -! call mpibcast(nswbands, 1, mpiint, 0, mpicom, ierr) -! call mpibcast(nlwbands, 1, mpiint, 0, mpicom, ierr) -#endif - - allocate(g_d_eff(n_g_d)) - allocate(ext_sw_ice(n_g_d,nswbands)) - allocate(ssa_sw_ice(n_g_d,nswbands)) - allocate(asm_sw_ice(n_g_d,nswbands)) - allocate(abs_lw_ice(n_g_d,nlwbands)) - - if(masterproc) then - call handle_ncerr( nf90_inq_varid(ncid, 'd_eff', d_id),& - 'cloud optics deff get') - call handle_ncerr( nf90_get_var(ncid, d_id, g_d_eff),& - 'read cloud optics deff values') - - call handle_ncerr( nf90_inq_varid(ncid, 'sw_ext', ext_sw_ice_id),& - 'cloud optics ext_sw_ice get') - call handle_ncerr(nf90_inquire_variable ( ncid, ext_sw_ice_id, ndims=ndims, dimids=vdimids),& - 'checking dimensions of ext_sw_ice') - call handle_ncerr(nf90_inquire_dimension( ncid, vdimids(1), len=templen),& - 'getting first dimension sw_ext') - !write(iulog,*) 'expected length',n_g_d,'actual len',templen - call handle_ncerr(nf90_inquire_dimension( ncid, vdimids(2), len=templen),& - 'getting first dimension sw_ext') - !write(iulog,*) 'expected length',nswbands,'actual len',templen - call handle_ncerr( nf90_get_var(ncid, ext_sw_ice_id, ext_sw_ice),& - 'read cloud optics ext_sw_ice values') - - call handle_ncerr( nf90_inq_varid(ncid, 'sw_ssa', ssa_sw_ice_id),& - 'cloud optics ssa_sw_ice get') - call handle_ncerr( nf90_get_var(ncid, ssa_sw_ice_id, ssa_sw_ice),& - 'read cloud optics ssa_sw_ice values') - - call handle_ncerr( nf90_inq_varid(ncid, 'sw_asm', asm_sw_ice_id),& - 'cloud optics asm_sw_ice get') - call handle_ncerr( nf90_get_var(ncid, asm_sw_ice_id, asm_sw_ice),& - 'read cloud optics asm_sw_ice values') - - call handle_ncerr( nf90_inq_varid(ncid, 'lw_abs', abs_lw_ice_id),& - 'cloud optics abs_lw_ice get') - call handle_ncerr( nf90_get_var(ncid, abs_lw_ice_id, abs_lw_ice),& - 'read cloud optics abs_lw_ice values') - - call handle_ncerr( nf90_close(ncid), 'ice optics file missing') - - endif ! if masterproc -#if ( defined SPMD ) - call mpibcast(g_d_eff, n_g_d, mpir8, 0, mpicom, ierr) - call mpibcast(ext_sw_ice, n_g_d*nswbands, mpir8, 0, mpicom, ierr) - call mpibcast(ssa_sw_ice, n_g_d*nswbands, mpir8, 0, mpicom, ierr) - call mpibcast(asm_sw_ice, n_g_d*nswbands, mpir8, 0, mpicom, ierr) - call mpibcast(abs_lw_ice, n_g_d*nlwbands, mpir8, 0, mpicom, ierr) -#endif - - return - -end subroutine cloud_rad_props_init - -!============================================================================== - -subroutine cloud_rad_props_get_sw(state, pbuf, & - tau, tau_w, tau_w_g, tau_w_f,& - diagnosticindex, oldliq, oldice) - -! return totaled (across all species) layer tau, omega, g, f -! for all spectral interval for aerosols affecting the climate - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - integer, optional, intent(in) :: diagnosticindex ! index (if present) to radiation diagnostic information - - real(r8), intent(out) :: tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8), intent(out) :: tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8), intent(out) :: tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8), intent(out) :: tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - logical, optional, intent(in) :: oldliq,oldice - - ! Local variables - - integer :: ncol - integer :: lchnk - integer :: k, i ! lev and daycolumn indices - integer :: iswband ! sw band indices - - ! optical props for each aerosol - real(r8), pointer :: h_ext(:,:) - real(r8), pointer :: h_ssa(:,:) - real(r8), pointer :: h_asm(:,:) - real(r8), pointer :: n_ext(:) - real(r8), pointer :: n_ssa(:) - real(r8), pointer :: n_asm(:) - - ! rad properties for liquid clouds - real(r8) :: liq_tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8) :: liq_tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - ! rad properties for ice clouds - real(r8) :: ice_tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8) :: ice_tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - ! initialize to conditions that would cause failure - tau (:,:,:) = -100._r8 - tau_w (:,:,:) = -100._r8 - tau_w_g (:,:,:) = -100._r8 - tau_w_f (:,:,:) = -100._r8 - - ! initialize layers to accumulate od's - tau (:,1:ncol,:) = 0._r8 - tau_w (:,1:ncol,:) = 0._r8 - tau_w_g(:,1:ncol,:) = 0._r8 - tau_w_f(:,1:ncol,:) = 0._r8 - - - call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) - - call get_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) - - tau (:,1:ncol,:) = liq_tau (:,1:ncol,:) + ice_tau (:,1:ncol,:) - tau_w (:,1:ncol,:) = liq_tau_w (:,1:ncol,:) + ice_tau_w (:,1:ncol,:) - tau_w_g(:,1:ncol,:) = liq_tau_w_g(:,1:ncol,:) + ice_tau_w_g(:,1:ncol,:) - tau_w_f(:,1:ncol,:) = liq_tau_w_f(:,1:ncol,:) + ice_tau_w_f(:,1:ncol,:) - -end subroutine cloud_rad_props_get_sw -!============================================================================== - -subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldliq, oldice, oldcloud) - -! Purpose: Compute cloud longwave absorption optical depth -! cloud_rad_props_get_lw() is called by radlw() - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer:: pbuf(:) - real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer - integer, optional, intent(in) :: diagnosticindex - logical, optional, intent(in) :: oldliq ! use old liquid optics - logical, optional, intent(in) :: oldice ! use old ice optics - logical, optional, intent(in) :: oldcloud ! use old optics for both (b4b) - - ! Local variables - - integer :: bnd_idx ! LW band index - integer :: i ! column index - integer :: k ! lev index - integer :: ncol ! number of columns - integer :: lchnk - - ! rad properties for liquid clouds - real(r8) :: liq_tau_abs_od(nlwbands,pcols,pver) ! liquid cloud absorption optical depth - - ! rad properties for ice clouds - real(r8) :: ice_tau_abs_od(nlwbands,pcols,pver) ! ice cloud absorption optical depth - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - ! compute optical depths cld_absod - cld_abs_od = 0._r8 - - if(present(oldcloud))then - if(oldcloud) then - ! make diagnostic calls to these first to output ice and liq OD's - !call old_liq_get_rad_props_lw(state, pbuf, liq_tau_abs_od, oldliqwp=.false.) - !call old_ice_get_rad_props_lw(state, pbuf, ice_tau_abs_od, oldicewp=.false.) - ! This affects climate (cld_abs_od) - call oldcloud_lw(state,pbuf,cld_abs_od,oldwp=.false.) - return - endif - endif - - if(present(oldliq))then - if(oldliq) then - call old_liq_get_rad_props_lw(state, pbuf, liq_tau_abs_od, oldliqwp=.false.) - else - call liquid_cloud_get_rad_props_lw(state, pbuf, liq_tau_abs_od) - endif - else - call liquid_cloud_get_rad_props_lw(state, pbuf, liq_tau_abs_od) - endif - - if(present(oldice))then - if(oldice) then - call old_ice_get_rad_props_lw(state, pbuf, ice_tau_abs_od, oldicewp=.false.) - else - call ice_cloud_get_rad_props_lw(state, pbuf, ice_tau_abs_od) - endif - else - call ice_cloud_get_rad_props_lw(state, pbuf, ice_tau_abs_od) - endif - - cld_abs_od(:,1:ncol,:) = liq_tau_abs_od(:,1:ncol,:) + ice_tau_abs_od(:,1:ncol,:) - -end subroutine cloud_rad_props_get_lw - -!============================================================================== - -subroutine get_snow_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - - real(r8), pointer :: icswpth(:,:), des(:,:) - - ! This does the same thing as get_ice_optics_sw, except with a different - ! water path and effective diameter. - call pbuf_get_field(pbuf, i_icswp, icswpth) - call pbuf_get_field(pbuf, i_des, des) - - call interpolate_ice_optics_sw(state%ncol, icswpth, des, tau, tau_w, & - tau_w_g, tau_w_f) - -end subroutine get_snow_optics_sw - -!============================================================================== - -subroutine get_grau_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - - real(r8), pointer :: icgrauwpth(:,:), degrau(:,:) - - integer :: i,k - - ! This does the same thing as get_ice_optics_sw, except with a different - ! water path and effective diameter. - if((i_icgrauwp > 0) .and. (i_degrau > 0)) then - - call pbuf_get_field(pbuf, i_icgrauwp, icgrauwpth) - call pbuf_get_field(pbuf, i_degrau, degrau) - - call interpolate_ice_optics_sw(state%ncol, icgrauwpth, degrau, tau, tau_w, & - tau_w_g, tau_w_f) - do i = 1, pcols - do k = 1, pver - if (tau(idx_sw_diag,i,k).gt.100._r8) then - write(iulog,*) 'WARNING: SW Graupel Tau > 100 (i,k,icgrauwpth,degrau,tau):' - write(iulog,*) i,k,icgrauwpth(i,k), degrau(i,k), tau(idx_sw_diag,i,k) - end if - enddo - enddo - - else - call endrun('ERROR: Get_grau_optics_sw called when graupel properties not supported') - end if - -end subroutine get_grau_optics_sw - -!============================================================================== -! Private methods -!============================================================================== - -subroutine get_ice_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - - real(r8), pointer :: iciwpth(:,:), dei(:,:) - - ! Get relevant pbuf fields, and interpolate optical properties from - ! the lookup tables. - call pbuf_get_field(pbuf, i_iciwp, iciwpth) - call pbuf_get_field(pbuf, i_dei, dei) - - call interpolate_ice_optics_sw(state%ncol, iciwpth, dei, tau, tau_w, & - tau_w_g, tau_w_f) - -end subroutine get_ice_optics_sw - -!============================================================================== - -subroutine interpolate_ice_optics_sw(ncol, iciwpth, dei, tau, tau_w, & - tau_w_g, tau_w_f) - - integer, intent(in) :: ncol - real(r8), intent(in) :: iciwpth(pcols,pver) - real(r8), intent(in) :: dei(pcols,pver) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - - type(interp_type) :: dei_wgts - - integer :: i, k, swband - real(r8) :: ext(nswbands), ssa(nswbands), asm(nswbands) - - do k = 1,pver - do i = 1,ncol - if( iciwpth(i,k) < 1.e-80_r8 .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 - tau_w_g(:,i,k) = 0._r8 - tau_w_f(:,i,k) = 0._r8 - else - ! for each cell interpolate to find weights in g_d_eff grid. - call lininterp_init(g_d_eff, n_g_d, dei(i:i,k), 1, & - extrap_method_bndry, dei_wgts) - ! interpolate into grid and extract radiative properties - do swband = 1, nswbands - call lininterp(ext_sw_ice(:,swband), n_g_d, & - ext(swband:swband), 1, dei_wgts) - call lininterp(ssa_sw_ice(:,swband), n_g_d, & - ssa(swband:swband), 1, dei_wgts) - call lininterp(asm_sw_ice(:,swband), n_g_d, & - asm(swband:swband), 1, dei_wgts) - end do - tau (:,i,k) = iciwpth(i,k) * ext - tau_w (:,i,k) = tau(:,i,k) * ssa - tau_w_g(:,i,k) = tau_w(:,i,k) * asm - tau_w_f(:,i,k) = tau_w_g(:,i,k) * asm - call lininterp_finish(dei_wgts) - endif - enddo - enddo - -end subroutine interpolate_ice_optics_sw - -!============================================================================== - -subroutine get_liquid_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - - real(r8), pointer, dimension(:,:) :: lamc, pgam, iclwpth - real(r8), dimension(pcols,pver) :: kext - integer i,k,swband,lchnk,ncol - - lchnk = state%lchnk - ncol = state%ncol - - - call pbuf_get_field(pbuf, i_lambda, lamc) - call pbuf_get_field(pbuf, i_mu, pgam) - call pbuf_get_field(pbuf, i_iclwp, iclwpth) - - do k = 1,pver - do i = 1,ncol - if(lamc(i,k) > 0._r8) then ! This seems to be clue from microphysics of no cloud - call gam_liquid_sw(iclwpth(i,k), lamc(i,k), pgam(i,k), & - tau(1:nswbands,i,k), tau_w(1:nswbands,i,k), tau_w_g(1:nswbands,i,k), tau_w_f(1:nswbands,i,k)) - else - tau(1:nswbands,i,k) = 0._r8 - tau_w(1:nswbands,i,k) = 0._r8 - tau_w_g(1:nswbands,i,k) = 0._r8 - tau_w_f(1:nswbands,i,k) = 0._r8 - endif - enddo - enddo - -end subroutine get_liquid_optics_sw - -!============================================================================== - -subroutine liquid_cloud_get_rad_props_lw(state, pbuf, abs_od) - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) - - integer :: lchnk, ncol - real(r8), pointer, dimension(:,:) :: lamc, pgam, iclwpth - - integer lwband, i, k - - abs_od = 0._r8 - - lchnk = state%lchnk - ncol = state%ncol - - call pbuf_get_field(pbuf, i_lambda, lamc) - call pbuf_get_field(pbuf, i_mu, pgam) - call pbuf_get_field(pbuf, i_iclwp, iclwpth) - - do k = 1,pver - do i = 1,ncol - if(lamc(i,k) > 0._r8) then ! This seems to be the clue for no cloud from microphysics formulation - call gam_liquid_lw(iclwpth(i,k), lamc(i,k), pgam(i,k), abs_od(1:nlwbands,i,k)) - else - abs_od(1:nlwbands,i,k) = 0._r8 - endif - enddo - enddo - -end subroutine liquid_cloud_get_rad_props_lw -!============================================================================== - -subroutine snow_cloud_get_rad_props_lw(state, pbuf, abs_od) - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) - - real(r8), pointer :: icswpth(:,:), des(:,:) - - ! This does the same thing as ice_cloud_get_rad_props_lw, except with a - ! different water path and effective diameter. - call pbuf_get_field(pbuf, i_icswp, icswpth) - call pbuf_get_field(pbuf, i_des, des) - - call interpolate_ice_optics_lw(state%ncol,icswpth, des, abs_od) - -end subroutine snow_cloud_get_rad_props_lw - - -!============================================================================== - -subroutine grau_cloud_get_rad_props_lw(state, pbuf, abs_od) - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) - - real(r8), pointer :: icgrauwpth(:,:), degrau(:,:) - - ! This does the same thing as ice_cloud_get_rad_props_lw, except with a - ! different water path and effective diameter. - if((i_icgrauwp > 0) .and. (i_degrau > 0)) then - call pbuf_get_field(pbuf, i_icgrauwp, icgrauwpth) - call pbuf_get_field(pbuf, i_degrau, degrau) - - call interpolate_ice_optics_lw(state%ncol,icgrauwpth, degrau, abs_od) - else - call endrun('ERROR: Grau_cloud_get_rad_props_lw called when graupel & - &properties not supported') - end if - -end subroutine grau_cloud_get_rad_props_lw - -!============================================================================== - -subroutine ice_cloud_get_rad_props_lw(state, pbuf, abs_od) - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) - - real(r8), pointer :: iciwpth(:,:), dei(:,:) - - ! Get relevant pbuf fields, and interpolate optical properties from - ! the lookup tables. - call pbuf_get_field(pbuf, i_iciwp, iciwpth) - call pbuf_get_field(pbuf, i_dei, dei) - - call interpolate_ice_optics_lw(state%ncol,iciwpth, dei, abs_od) - -end subroutine ice_cloud_get_rad_props_lw - -!============================================================================== - -subroutine interpolate_ice_optics_lw(ncol, iciwpth, dei, abs_od) - - integer, intent(in) :: ncol - real(r8), intent(in) :: iciwpth(pcols,pver) - real(r8), intent(in) :: dei(pcols,pver) - - real(r8),intent(out) :: abs_od(nlwbands,pcols,pver) - - type(interp_type) :: dei_wgts - - integer :: i, k, lwband - real(r8) :: absor(nlwbands) - - 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 - abs_od (:,i,k) = 0._r8 - else - ! for each cell interpolate to find weights in g_d_eff grid. - call lininterp_init(g_d_eff, n_g_d, dei(i:i,k), 1, & - extrap_method_bndry, dei_wgts) - ! interpolate into grid and extract radiative properties - do lwband = 1, nlwbands - call lininterp(abs_lw_ice(:,lwband), n_g_d, & - absor(lwband:lwband), 1, dei_wgts) - enddo - abs_od(:,i,k) = iciwpth(i,k) * absor - where(abs_od(:,i,k) > 50.0_r8) abs_od(:,i,k) = 50.0_r8 - call lininterp_finish(dei_wgts) - endif - enddo - enddo - -end subroutine interpolate_ice_optics_lw - -!============================================================================== - -subroutine gam_liquid_lw(clwptn, lamc, pgam, abs_od) - real(r8), intent(in) :: clwptn ! cloud water liquid path new (in cloud) (in g/m^2)? - real(r8), intent(in) :: lamc ! prognosed value of lambda for cloud - real(r8), intent(in) :: pgam ! prognosed value of mu for cloud - real(r8), intent(out) :: abs_od(1:nlwbands) - - integer :: lwband ! sw band index - - type(interp_type) :: mu_wgts - type(interp_type) :: lambda_wgts - - if (clwptn < 1.e-80_r8) then - abs_od = 0._r8 - return - endif - - call get_mu_lambda_weights(lamc, pgam, mu_wgts, lambda_wgts) - - do lwband = 1, nlwbands - call lininterp(abs_lw_liq(:,:,lwband), nmu, nlambda, & - abs_od(lwband:lwband), 1, mu_wgts, lambda_wgts) - enddo - - abs_od = clwptn * abs_od - - call lininterp_finish(mu_wgts) - call lininterp_finish(lambda_wgts) - -end subroutine gam_liquid_lw - -!============================================================================== - -subroutine gam_liquid_sw(clwptn, lamc, pgam, tau, tau_w, tau_w_g, tau_w_f) - real(r8), intent(in) :: clwptn ! cloud water liquid path new (in cloud) (in g/m^2)? - real(r8), intent(in) :: lamc ! prognosed value of lambda for cloud - real(r8), intent(in) :: pgam ! prognosed value of mu for cloud - real(r8), intent(out) :: tau(1:nswbands), tau_w(1:nswbands), tau_w_f(1:nswbands), tau_w_g(1:nswbands) - - integer :: swband ! sw band index - - real(r8) :: ext(nswbands), ssa(nswbands), asm(nswbands) - - type(interp_type) :: mu_wgts - type(interp_type) :: lambda_wgts - - if (clwptn < 1.e-80_r8) then - tau = 0._r8 - tau_w = 0._r8 - tau_w_g = 0._r8 - tau_w_f = 0._r8 - return - endif - - call get_mu_lambda_weights(lamc, pgam, mu_wgts, lambda_wgts) - - do swband = 1, nswbands - call lininterp(ext_sw_liq(:,:,swband), nmu, nlambda, & - ext(swband:swband), 1, mu_wgts, lambda_wgts) - call lininterp(ssa_sw_liq(:,:,swband), nmu, nlambda, & - ssa(swband:swband), 1, mu_wgts, lambda_wgts) - call lininterp(asm_sw_liq(:,:,swband), nmu, nlambda, & - asm(swband:swband), 1, mu_wgts, lambda_wgts) - enddo - - ! compute radiative properties - tau = clwptn * ext - tau_w = tau * ssa - tau_w_g = tau_w * asm - tau_w_f = tau_w_g * asm - - call lininterp_finish(mu_wgts) - call lininterp_finish(lambda_wgts) - -end subroutine gam_liquid_sw - -!============================================================================== - -subroutine get_mu_lambda_weights(lamc, pgam, mu_wgts, lambda_wgts) - real(r8), intent(in) :: lamc ! prognosed value of lambda for cloud - real(r8), intent(in) :: pgam ! prognosed value of mu for cloud - ! Output interpolation weights. Caller is responsible for freeing these. - type(interp_type), intent(out) :: mu_wgts - type(interp_type), intent(out) :: lambda_wgts - - integer :: ilambda - real(r8) :: g_lambda_interp(nlambda) - - ! Make interpolation weights for mu. - ! (Put pgam in a temporary array for this purpose.) - call lininterp_init(g_mu, nmu, [pgam], 1, extrap_method_bndry, mu_wgts) - - ! Use mu weights to interpolate to a row in the lambda table. - do ilambda = 1, nlambda - call lininterp(g_lambda(:,ilambda), nmu, & - g_lambda_interp(ilambda:ilambda), 1, mu_wgts) - end do - - ! Make interpolation weights for lambda. - call lininterp_init(g_lambda_interp, nlambda, [lamc], 1, & - extrap_method_bndry, lambda_wgts) - -end subroutine get_mu_lambda_weights - -!============================================================================== - -end module cloud_rad_props diff --git a/src/physics/rrtmg/ebert_curry.F90 b/src/physics/rrtmg/ebert_curry.F90 deleted file mode 100644 index 7bca4ce257..0000000000 --- a/src/physics/rrtmg/ebert_curry.F90 +++ /dev/null @@ -1,408 +0,0 @@ -module ebert_curry - -!------------------------------------------------------------------------------------------------ -!------------------------------------------------------------------------------------------------ - -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pcols, pver, pverp -use physics_types, only: physics_state -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx -use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_lw_diag, get_sw_spectral_boundaries -use cam_abortutils, only: endrun -use cam_history, only: outfld - -implicit none -private -save - -public :: & - ec_rad_props_init, & - cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols - cloud_rad_props_get_lw, & ! return LW optical props of total bulk aerosols - ec_ice_optics_sw, & - ec_ice_get_rad_props_lw - - -real(r8), public, parameter:: scalefactor = 1._r8 !500._r8/917._r8 - -! Minimum cloud amount (as a fraction of the grid-box area) to -! distinguish from clear sky -! - real(r8) cldmin - parameter (cldmin = 1.0e-80_r8) -! -! Decimal precision of cloud amount (0 -> preserve full resolution; -! 10^-n -> preserve n digits of cloud amount) -! - real(r8) cldeps - parameter (cldeps = 0.0_r8) - -! -! indexes into pbuf for optical parameters of MG clouds -! - integer :: dei_idx = 0 - integer :: mu_idx = 0 - integer :: lambda_idx = 0 - integer :: iciwp_idx = 0 - integer :: iclwp_idx = 0 - integer :: cld_idx = 0 - integer :: rei_idx = 0 - -! indexes into constituents for old optics - integer :: & - ixcldice, & ! cloud ice water index - ixcldliq ! cloud liquid water index - - -!============================================================================== -contains -!============================================================================== - -subroutine ec_rad_props_init() - -! use cam_history, only: addfld - use netcdf - use spmd_utils, only: masterproc - use ioFileMod, only: getfil - use cam_logfile, only: iulog - use error_messages, only: handle_ncerr -#if ( defined SPMD ) - use mpishorthand -#endif - use constituents, only: cnst_get_ind - - integer :: err - - iciwp_idx = pbuf_get_index('ICIWP',errcode=err) - iclwp_idx = pbuf_get_index('ICLWP',errcode=err) - cld_idx = pbuf_get_index('CLD') - rei_idx = pbuf_get_index('REI') - - ! old optics - call cnst_get_ind('CLDICE', ixcldice) - call cnst_get_ind('CLDLIQ', ixcldliq) - - !call addfld ('CLWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','old In Cloud Liquid Water Path', sampling_seq='rad_lwsw') - !call addfld ('KEXT_OLD',(/ 'lev' /),'I','m^2/kg','old extinction') - !call addfld ('CLDOD_OLD',(/ 'lev' /),'I','1','old liquid OD') - !call addfld ('REL_OLD',(/ 'lev' /),'I','1','old liquid effective radius (liquid)') - - !call addfld ('CLWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Liquid Water Path', sampling_seq='rad_lwsw') - !call addfld ('KEXT_NEW',(/ 'lev' /),'I','m^2/kg','extinction') - !call addfld ('CLDOD_NEW',(/ 'lev' /),'I','1','liquid OD') - - !call addfld('CIWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path', sampling_seq='rad_lwsw') - !call addfld('CIWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path (old)', sampling_seq='rad_lwsw') - - return - -end subroutine ec_rad_props_init - -!============================================================================== - -subroutine cloud_rad_props_get_sw(state, pbuf, & - tau, tau_w, tau_w_g, tau_w_f,& - diagnosticindex, oldliq, oldice) - -! return totaled (across all species) layer tau, omega, g, f -! for all spectral interval for aerosols affecting the climate - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - integer, optional, intent(in) :: diagnosticindex ! index (if present) to radiation diagnostic information - - real(r8), intent(out) :: tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8), intent(out) :: tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8), intent(out) :: tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8), intent(out) :: tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - logical, optional, intent(in) :: oldliq,oldice - - ! Local variables - - integer :: ncol - integer :: lchnk - integer :: k, i ! lev and daycolumn indices - integer :: iswband ! sw band indices - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - ! initialize to conditions that would cause failure - tau (:,:,:) = -100._r8 - tau_w (:,:,:) = -100._r8 - tau_w_g (:,:,:) = -100._r8 - tau_w_f (:,:,:) = -100._r8 - - ! initialize layers to accumulate od's - tau (:,1:ncol,:) = 0._r8 - tau_w (:,1:ncol,:) = 0._r8 - tau_w_g(:,1:ncol,:) = 0._r8 - tau_w_f(:,1:ncol,:) = 0._r8 - - - call ec_ice_optics_sw (state, pbuf, tau, tau_w, tau_w_g, tau_w_f, oldicewp=.true.) -! call outfld ('CI_OD_SW_OLD', ice_tau(idx_sw_diag,:,:), pcols, lchnk) - - -end subroutine cloud_rad_props_get_sw -!============================================================================== - -subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldliq, oldice, oldcloud) - -! Purpose: Compute cloud longwave absorption optical depth -! cloud_rad_props_get_lw() is called by radlw() - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer - integer, optional, intent(in) :: diagnosticindex - logical, optional, intent(in) :: oldliq ! use old liquid optics - logical, optional, intent(in) :: oldice ! use old ice optics - logical, optional, intent(in) :: oldcloud ! use old optics for both (b4b) - - ! Local variables - - integer :: bnd_idx ! LW band index - integer :: i ! column index - integer :: k ! lev index - integer :: ncol ! number of columns - integer :: lchnk - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - ! compute optical depths cld_absod - cld_abs_od = 0._r8 - - call ec_ice_get_rad_props_lw(state, pbuf, cld_abs_od, oldicewp=.true.) - !call outfld('CI_OD_LW_OLD', ice_tau_abs_od(idx_lw_diag ,:,:), pcols, lchnk) - -end subroutine cloud_rad_props_get_lw - -!============================================================================== -! Private methods -!============================================================================== - -subroutine ec_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp) - - use physconst, only: gravit - - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - logical, intent(in) :: oldicewp - - real(r8), pointer, dimension(:,:) :: rei - real(r8), pointer, dimension(:,:) :: cldn - real(r8), pointer, dimension(:,:) :: tmpptr - real(r8), dimension(pcols,pver) :: cicewp - real(r8), dimension(nswbands) :: wavmin - real(r8), dimension(nswbands) :: wavmax - ! - ! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836) - real(r8) :: abari(4) = & ! a coefficient for extinction optical depth - (/ 3.448e-03_r8, 3.448e-03_r8,3.448e-03_r8,3.448e-03_r8/) - real(r8) :: bbari(4) = & ! b coefficient for extinction optical depth - (/ 2.431_r8 , 2.431_r8 ,2.431_r8 ,2.431_r8 /) - real(r8) :: cbari(4) = & ! c coefficient for single scat albedo - (/ 1.00e-05_r8 , 1.10e-04_r8 ,1.861e-02_r8,.46658_r8 /) - real(r8) :: dbari(4) = & ! d coefficient for single scat albedo - (/ 0.0_r8 , 1.405e-05_r8,8.328e-04_r8,2.05e-05_r8 /) - real(r8) :: ebari(4) = & ! e coefficient for asymmetry parameter - (/ 0.7661_r8 , 0.7730_r8 ,0.794_r8 ,0.9595_r8 /) - real(r8) :: fbari(4) = & ! f coefficient for asymmetry parameter - (/ 5.851e-04_r8, 5.665e-04_r8,7.267e-04_r8,1.076e-04_r8/) - - real(r8) :: abarii ! A coefficient for current spectral band - real(r8) :: bbarii ! B coefficient for current spectral band - real(r8) :: cbarii ! C coefficient for current spectral band - real(r8) :: dbarii ! D coefficient for current spectral band - real(r8) :: ebarii ! E coefficient for current spectral band - real(r8) :: fbarii ! F coefficient for current spectral band - - ! Minimum cloud amount (as a fraction of the grid-box area) to - ! distinguish from clear sky - real(r8), parameter :: cldmin = 1.0e-80_r8 - - ! Decimal precision of cloud amount (0 -> preserve full resolution; - ! 10^-n -> preserve n digits of cloud amount) - real(r8), parameter :: cldeps = 0.0_r8 - - integer :: ns, i, k, indxsl, lchnk, Nday - integer :: itim_old - real(r8) :: tmp1i, tmp2i, tmp3i, g - - Nday = state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx,cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, rei_idx,rei) - - if(oldicewp) then - do k=1,pver - do i = 1,Nday - cicewp(i,k) = 1000.0_r8*state%q(i,k,ixcldice)*state%pdel(i,k) /(gravit* max(0.01_r8,cldn(i,k))) - end do - end do - else - if (iciwp_idx<=0) then - call endrun('ec_ice_optics_sw: oldicewp must be set to true since ICIWP was not found in pbuf') - endif - call pbuf_get_field(pbuf, iciwp_idx, tmpptr) - cicewp(1:pcols,1:pver) = 1000.0_r8*tmpptr(1:pcols,1:pver) - endif - - call get_sw_spectral_boundaries(wavmin,wavmax,'microns') - - do ns = 1, nswbands - - if(wavmax(ns) <= 0.7_r8) then - indxsl = 1 - else if(wavmax(ns) <= 1.25_r8) then - indxsl = 2 - else if(wavmax(ns) <= 2.38_r8) then - indxsl = 3 - else if(wavmax(ns) > 2.38_r8) then - indxsl = 4 - end if - - abarii = abari(indxsl) - bbarii = bbari(indxsl) - cbarii = cbari(indxsl) - dbarii = dbari(indxsl) - ebarii = ebari(indxsl) - fbarii = fbari(indxsl) - - do k=1,pver - do i=1,Nday - - ! note that optical properties for ice valid only - ! in range of 13 > rei > 130 micron (Ebert and Curry 92) - if (cldn(i,k) >= cldmin .and. cldn(i,k) >= cldeps) then - tmp1i = abarii + bbarii/max(13._r8,min(scalefactor*rei(i,k),130._r8)) - ice_tau(ns,i,k) = cicewp(i,k)*tmp1i - else - ice_tau(ns,i,k) = 0.0_r8 - endif - - tmp2i = 1._r8 - cbarii - dbarii*min(max(13._r8,scalefactor*rei(i,k)),130._r8) - tmp3i = fbarii*min(max(13._r8,scalefactor*rei(i,k)),130._r8) - ! Do not let single scatter albedo be 1. Delta-eddington solution - ! for non-conservative case has different analytic form from solution - ! for conservative case, and raddedmx is written for non-conservative case. - ice_tau_w(ns,i,k) = ice_tau(ns,i,k) * min(tmp2i,.999999_r8) - g = ebarii + tmp3i - ice_tau_w_g(ns,i,k) = ice_tau_w(ns,i,k) * g - ice_tau_w_f(ns,i,k) = ice_tau_w(ns,i,k) * g * g - - end do ! End do i=1,Nday - end do ! End do k=1,pver - end do ! nswbands - -end subroutine ec_ice_optics_sw -!============================================================================== - -subroutine ec_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp) - use physconst, only: gravit - - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) - logical, intent(in) :: oldicewp - - real(r8) :: gicewp(pcols,pver) - real(r8) :: gliqwp(pcols,pver) - real(r8) :: cicewp(pcols,pver) - real(r8) :: cliqwp(pcols,pver) - real(r8) :: ficemr(pcols,pver) - real(r8) :: cwp(pcols,pver) - real(r8) :: cldtau(pcols,pver) - - real(r8), pointer, dimension(:,:) :: cldn - 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), pointer, dimension(:,:) :: iclwpth, iciwpth - - - ncol = state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, rei_idx, rei) - call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - - if(oldicewp) then - do k=1,pver - do i = 1,ncol - gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path. - gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path. - cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. - cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. - ficemr(i,k) = state%q(i,k,ixcldice) / & - max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq))) - end do - end do - cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) - else - if (iclwp_idx<=0 .or. iciwp_idx<=0) then - call endrun('ec_ice_get_rad_props_lw: oldicewp must be set to true since ICIWP and/or ICLWP were not found in pbuf') - endif - call pbuf_get_field(pbuf, iclwp_idx, iclwpth) - call pbuf_get_field(pbuf, iciwp_idx, iciwpth) - do k=1,pver - do i = 1,ncol - cwp(i,k) = 1000.0_r8 *iciwpth(i,k) + 1000.0_r8 *iclwpth(i,k) - ficemr(i,k) = 1000.0_r8*iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k))) - end do - end do - endif - - do k=1,pver - do i=1,ncol - - ! Note from Andrew Conley: - ! Optics for RK no longer supported, This is constructed to get - ! close to bit for bit. Otherwise we could simply use ice water path - !note that optical properties for ice valid only - !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 - - !if(oldicewp) then - ! call outfld('CIWPTH_OLD',cicewp(:,:)/1000,pcols,lchnk) - !else - ! call outfld('CIWPTH_OLD',iciwpth(:,:),pcols,lchnk) - !endif - !call outfld('CI_OD_LW_OLD',cldtau(:,:),pcols,lchnk) - -end subroutine ec_ice_get_rad_props_lw -!============================================================================== - -end module ebert_curry diff --git a/src/physics/rrtmg/oldcloud.F90 b/src/physics/rrtmg/oldcloud.F90 deleted file mode 100644 index fb0ae4d80e..0000000000 --- a/src/physics/rrtmg/oldcloud.F90 +++ /dev/null @@ -1,643 +0,0 @@ -module oldcloud - -!------------------------------------------------------------------------------------------------ -!------------------------------------------------------------------------------------------------ - -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pcols, pver, pverp -use physics_types, only: physics_state -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field -use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_lw_diag, get_sw_spectral_boundaries -use cam_abortutils, only: endrun -use cam_history, only: outfld -use rad_constituents, only: iceopticsfile, liqopticsfile -use ebert_curry, only: scalefactor - -implicit none -private -save - -public :: & - oldcloud_init, oldcloud_lw, old_liq_get_rad_props_lw, old_ice_get_rad_props_lw - -integer :: nmu, nlambda -real(r8), allocatable :: g_mu(:) ! mu samples on grid -real(r8), allocatable :: g_lambda(:,:) ! lambda scale samples on grid -real(r8), allocatable :: ext_sw_liq(:,:,:) -real(r8), allocatable :: ssa_sw_liq(:,:,:) -real(r8), allocatable :: asm_sw_liq(:,:,:) -real(r8), allocatable :: abs_lw_liq(:,:,:) - -integer :: n_g_d -real(r8), allocatable :: g_d_eff(:) ! radiative effective diameter samples on grid -real(r8), allocatable :: ext_sw_ice(:,:) -real(r8), allocatable :: ssa_sw_ice(:,:) -real(r8), allocatable :: asm_sw_ice(:,:) -real(r8), allocatable :: abs_lw_ice(:,:) - -! Minimum cloud amount (as a fraction of the grid-box area) to -! distinguish from clear sky -! - real(r8) cldmin - parameter (cldmin = 1.0e-80_r8) -! -! Decimal precision of cloud amount (0 -> preserve full resolution; -! 10^-n -> preserve n digits of cloud amount) -! - real(r8) cldeps - parameter (cldeps = 0.0_r8) - -! -! indexes into pbuf for optical parameters of MG clouds -! - integer :: iciwp_idx = 0 - integer :: iclwp_idx = 0 - integer :: cld_idx = 0 - integer :: rel_idx = 0 - integer :: rei_idx = 0 - -! indexes into constituents for old optics - integer :: & - ixcldice, & ! cloud ice water index - ixcldliq ! cloud liquid water index - - -!============================================================================== -contains -!============================================================================== - -subroutine oldcloud_init() - - use constituents, only: cnst_get_ind - - integer :: err - - iciwp_idx = pbuf_get_index('ICIWP',errcode=err) - iclwp_idx = pbuf_get_index('ICLWP',errcode=err) - cld_idx = pbuf_get_index('CLD') - rel_idx = pbuf_get_index('REL') - rei_idx = pbuf_get_index('REI') - - ! old optics - call cnst_get_ind('CLDICE', ixcldice) - call cnst_get_ind('CLDLIQ', ixcldliq) - - return - -end subroutine oldcloud_init - -!============================================================================== -! Private methods -!============================================================================== - -subroutine old_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp) - - use physconst, only: gravit - - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - logical, intent(in) :: oldliqwp - - real(r8), pointer, dimension(:,:) :: rel - real(r8), pointer, dimension(:,:) :: cldn - real(r8), pointer, dimension(:,:) :: tmpptr - real(r8), dimension(pcols,pver) :: cliqwp - real(r8), dimension(nswbands) :: wavmin - real(r8), dimension(nswbands) :: wavmax - - ! Minimum cloud amount (as a fraction of the grid-box area) to - ! distinguish from clear sky - real(r8), parameter :: cldmin = 1.0e-80_r8 - - ! Decimal precision of cloud amount (0 -> preserve full resolution; - ! 10^-n -> preserve n digits of cloud amount) - real(r8), parameter :: cldeps = 0.0_r8 - - ! A. Slingo's data for cloud particle radiative properties (from 'A GCM - ! Parameterization for the Shortwave Properties of Water Clouds' JAS - ! vol. 46 may 1989 pp 1419-1427) - real(r8) :: abarl(4) = & ! A coefficient for extinction optical depth - (/ 2.817e-02_r8, 2.682e-02_r8,2.264e-02_r8,1.281e-02_r8/) - real(r8) :: bbarl(4) = & ! B coefficient for extinction optical depth - (/ 1.305_r8 , 1.346_r8 ,1.454_r8 ,1.641_r8 /) - real(r8) :: cbarl(4) = & ! C coefficient for single scat albedo - (/-5.62e-08_r8 ,-6.94e-06_r8 ,4.64e-04_r8 ,0.201_r8 /) - real(r8) :: dbarl(4) = & ! D coefficient for single scat albedo - (/ 1.63e-07_r8 , 2.35e-05_r8 ,1.24e-03_r8 ,7.56e-03_r8 /) - real(r8) :: ebarl(4) = & ! E coefficient for asymmetry parameter - (/ 0.829_r8 , 0.794_r8 ,0.754_r8 ,0.826_r8 /) - real(r8) :: fbarl(4) = & ! F coefficient for asymmetry parameter - (/ 2.482e-03_r8, 4.226e-03_r8,6.560e-03_r8,4.353e-03_r8/) - - real(r8) :: abarli ! A coefficient for current spectral band - real(r8) :: bbarli ! B coefficient for current spectral band - real(r8) :: cbarli ! C coefficient for current spectral band - real(r8) :: dbarli ! D coefficient for current spectral band - real(r8) :: ebarli ! E coefficient for current spectral band - real(r8) :: fbarli ! F coefficient for current spectral band - - ! Caution... A. Slingo recommends no less than 4.0 micro-meters nor - ! greater than 20 micro-meters - - integer :: ns, i, k, indxsl, Nday - integer :: lchnk, itim_old - real(r8) :: tmp1l, tmp2l, tmp3l, g - real(r8) :: kext(pcols,pver) - real(r8), pointer, dimension(:,:) :: iclwpth - - Nday = state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx,cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, rel_idx,rel) - - if (oldliqwp) then - do k=1,pver - do i = 1,Nday - cliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/(gravit*max(0.01_r8,cldn(i,k))) - end do - end do - else - if (iclwp_idx<0) then - call endrun('old_liquid_optics_sw: oldliqwp must be set to true since ICLWP was not found in pbuf') - endif - ! The following is the eventual target specification for in cloud liquid water path. - call pbuf_get_field(pbuf, iclwp_idx, tmpptr) - cliqwp = tmpptr - endif - - call get_sw_spectral_boundaries(wavmin,wavmax,'microns') - - do ns = 1, nswbands - ! Set index for cloud particle properties based on the wavelength, - ! according to A. Slingo (1989) equations 1-3: - ! Use index 1 (0.25 to 0.69 micrometers) for visible - ! Use index 2 (0.69 - 1.19 micrometers) for near-infrared - ! Use index 3 (1.19 to 2.38 micrometers) for near-infrared - ! Use index 4 (2.38 to 4.00 micrometers) for near-infrared - if(wavmax(ns) <= 0.7_r8) then - indxsl = 1 - else if(wavmax(ns) <= 1.25_r8) then - indxsl = 2 - else if(wavmax(ns) <= 2.38_r8) then - indxsl = 3 - else if(wavmin(ns) > 2.38_r8) then - indxsl = 4 - end if - - ! Set cloud extinction optical depth, single scatter albedo, - ! asymmetry parameter, and forward scattered fraction: - abarli = abarl(indxsl) - bbarli = bbarl(indxsl) - cbarli = cbarl(indxsl) - dbarli = dbarl(indxsl) - ebarli = ebarl(indxsl) - fbarli = fbarl(indxsl) - - do k=1,pver - do i=1,Nday - - ! note that optical properties for liquid valid only - ! in range of 4.2 > rel > 16 micron (Slingo 89) - if (cldn(i,k) >= cldmin .and. cldn(i,k) >= cldeps) then - tmp1l = abarli + bbarli/min(max(4.2_r8,rel(i,k)),16._r8) - liq_tau(ns,i,k) = 1000._r8*cliqwp(i,k)*tmp1l - else - liq_tau(ns,i,k) = 0.0_r8 - endif - - tmp2l = 1._r8 - cbarli - dbarli*min(max(4.2_r8,rel(i,k)),16._r8) - tmp3l = fbarli*min(max(4.2_r8,rel(i,k)),16._r8) - ! Do not let single scatter albedo be 1. Delta-eddington solution - ! for non-conservative case has different analytic form from solution - ! for conservative case, and raddedmx is written for non-conservative case. - liq_tau_w(ns,i,k) = liq_tau(ns,i,k) * min(tmp2l,.999999_r8) - g = ebarli + tmp3l - liq_tau_w_g(ns,i,k) = liq_tau_w(ns,i,k) * g - liq_tau_w_f(ns,i,k) = liq_tau_w(ns,i,k) * g * g - - end do ! End do i=1,Nday - end do ! End do k=1,pver - end do ! nswbands - - !call outfld('CL_OD_SW_OLD',liq_tau(idx_sw_diag,:,:), pcols, lchnk) - !call outfld('REL_OLD',rel(:,:), pcols, lchnk) - !call outfld('CLWPTH_OLD',cliqwp(:,:), pcols, lchnk) - !call outfld('KEXT_OLD',kext(:,:), pcols, lchnk) - - -end subroutine old_liquid_optics_sw -!============================================================================== - -subroutine old_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp) - - use physconst, only: gravit - - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - logical, intent(in) :: oldicewp - - real(r8), pointer, dimension(:,:) :: rei - real(r8), pointer, dimension(:,:) :: cldn - real(r8), pointer, dimension(:,:) :: tmpptr - real(r8), dimension(pcols,pver) :: cicewp - real(r8), dimension(nswbands) :: wavmin - real(r8), dimension(nswbands) :: wavmax - ! - ! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836) - real(r8) :: abari(4) = & ! a coefficient for extinction optical depth - (/ 3.448e-03_r8, 3.448e-03_r8,3.448e-03_r8,3.448e-03_r8/) - real(r8) :: bbari(4) = & ! b coefficient for extinction optical depth - (/ 2.431_r8 , 2.431_r8 ,2.431_r8 ,2.431_r8 /) - real(r8) :: cbari(4) = & ! c coefficient for single scat albedo - (/ 1.00e-05_r8 , 1.10e-04_r8 ,1.861e-02_r8,.46658_r8 /) - real(r8) :: dbari(4) = & ! d coefficient for single scat albedo - (/ 0.0_r8 , 1.405e-05_r8,8.328e-04_r8,2.05e-05_r8 /) - real(r8) :: ebari(4) = & ! e coefficient for asymmetry parameter - (/ 0.7661_r8 , 0.7730_r8 ,0.794_r8 ,0.9595_r8 /) - real(r8) :: fbari(4) = & ! f coefficient for asymmetry parameter - (/ 5.851e-04_r8, 5.665e-04_r8,7.267e-04_r8,1.076e-04_r8/) - - real(r8) :: abarii ! A coefficient for current spectral band - real(r8) :: bbarii ! B coefficient for current spectral band - real(r8) :: cbarii ! C coefficient for current spectral band - real(r8) :: dbarii ! D coefficient for current spectral band - real(r8) :: ebarii ! E coefficient for current spectral band - real(r8) :: fbarii ! F coefficient for current spectral band - - ! Minimum cloud amount (as a fraction of the grid-box area) to - ! distinguish from clear sky - real(r8), parameter :: cldmin = 1.0e-80_r8 - - ! Decimal precision of cloud amount (0 -> preserve full resolution; - ! 10^-n -> preserve n digits of cloud amount) - real(r8), parameter :: cldeps = 0.0_r8 - - integer :: ns, i, k, indxsl, lchnk, Nday - integer :: itim_old - real(r8) :: tmp1i, tmp2i, tmp3i, g - - Nday = state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx,cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, rei_idx,rei) - - if(oldicewp) then - do k=1,pver - do i = 1,Nday - cicewp(i,k) = 1000.0_r8*state%q(i,k,ixcldice)*state%pdel(i,k) /(gravit* max(0.01_r8,cldn(i,k))) - end do - end do - else - if (iciwp_idx<=0) then - call endrun('old_ice_optics_sw: oldicewp must be set to true since ICIWP was not found in pbuf') - endif - call pbuf_get_field(pbuf, iciwp_idx, tmpptr) - cicewp(1:pcols,1:pver) = 1000.0_r8*tmpptr - endif - - call get_sw_spectral_boundaries(wavmin,wavmax,'microns') - - do ns = 1, nswbands - - if(wavmax(ns) <= 0.7_r8) then - indxsl = 1 - else if(wavmax(ns) <= 1.25_r8) then - indxsl = 2 - else if(wavmax(ns) <= 2.38_r8) then - indxsl = 3 - else if(wavmin(ns) > 2.38_r8) then - indxsl = 4 - end if - - abarii = abari(indxsl) - bbarii = bbari(indxsl) - cbarii = cbari(indxsl) - dbarii = dbari(indxsl) - ebarii = ebari(indxsl) - fbarii = fbari(indxsl) - - do k=1,pver - do i=1,Nday - - ! note that optical properties for ice valid only - ! in range of 13 > rei > 130 micron (Ebert and Curry 92) - if (cldn(i,k) >= cldmin .and. cldn(i,k) >= cldeps) then - tmp1i = abarii + bbarii/max(13._r8,min(scalefactor*rei(i,k),130._r8)) - ice_tau(ns,i,k) = cicewp(i,k)*tmp1i - else - ice_tau(ns,i,k) = 0.0_r8 - endif - - tmp2i = 1._r8 - cbarii - dbarii*min(max(13._r8,scalefactor*rei(i,k)),130._r8) - tmp3i = fbarii*min(max(13._r8,scalefactor*rei(i,k)),130._r8) - ! Do not let single scatter albedo be 1. Delta-eddington solution - ! for non-conservative case has different analytic form from solution - ! for conservative case, and raddedmx is written for non-conservative case. - ice_tau_w(ns,i,k) = ice_tau(ns,i,k) * min(tmp2i,.999999_r8) - g = ebarii + tmp3i - ice_tau_w_g(ns,i,k) = ice_tau_w(ns,i,k) * g - ice_tau_w_f(ns,i,k) = ice_tau_w(ns,i,k) * g * g - - end do ! End do i=1,Nday - end do ! End do k=1,pver - end do ! nswbands - -end subroutine old_ice_optics_sw -!============================================================================== - -subroutine oldcloud_lw(state,pbuf,cld_abs_od,oldwp) - use physconst, only: gravit - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer - logical,intent(in) :: oldwp ! use old definition of waterpath - - - real(r8) :: gicewp(pcols,pver) - real(r8) :: gliqwp(pcols,pver) - real(r8) :: cicewp(pcols,pver) - real(r8) :: cliqwp(pcols,pver) - real(r8) :: ficemr(pcols,pver) - real(r8) :: cwp(pcols,pver) - real(r8) :: cldtau(pcols,pver) - - real(r8), pointer, dimension(:,:) :: cldn - real(r8), pointer, dimension(:,:) :: rei - 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) - - - - ncol = state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, rei_idx, rei) - call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - if (oldwp) then - do k=1,pver - do i = 1,ncol - gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path. - gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path. - cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. - cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. - ficemr(i,k) = state%q(i,k,ixcldice) / & - max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq))) - end do - end do - cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) - else - if (iclwp_idx<=0 .or. iciwp_idx<=0) then - call endrun('oldcloud_lw: oldwp must be set to true since ICIWP and/or ICLWP were not found in pbuf') - endif - call pbuf_get_field(pbuf, iclwp_idx, iclwpth) - call pbuf_get_field(pbuf, iciwp_idx, iciwpth) - do k=1,pver - do i = 1,ncol - cwp(i,k) = 1000.0_r8 *iclwpth(i,k) + 1000.0_r8 *iciwpth(i, k) - ficemr(i,k) = 1000.0_r8 * iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k))) - end do - end do - endif - - do k=1,pver - do i=1,ncol - - !note that optical properties for ice valid only - !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 - cld_abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver) - enddo - -end subroutine oldcloud_lw - -!============================================================================== -subroutine old_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp) - use physconst, only: gravit - - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) - logical, intent(in) :: oldliqwp - - real(r8) :: gicewp(pcols,pver) - real(r8) :: gliqwp(pcols,pver) - real(r8) :: cicewp(pcols,pver) - real(r8) :: cliqwp(pcols,pver) - real(r8) :: ficemr(pcols,pver) - real(r8) :: cwp(pcols,pver) - real(r8) :: cldtau(pcols,pver) - - real(r8), pointer, dimension(:,:) :: cldn - 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), pointer, dimension(:,:) :: iclwpth, iciwpth - - ncol=state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, rei_idx, rei) - call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - if (oldliqwp) then - do k=1,pver - do i = 1,ncol - gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path. - gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path. - cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. - cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. - ficemr(i,k) = state%q(i,k,ixcldice) / & - max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq))) - end do - end do - cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) - else - if (iclwp_idx<=0 .or. iciwp_idx<=0) then - call endrun('old_liq_get_rad_props_lw: oldliqwp must be set to true since ICIWP and/or ICLWP were not found in pbuf') - endif - call pbuf_get_field(pbuf, iclwp_idx, iclwpth) - call pbuf_get_field(pbuf, iciwp_idx, iciwpth) - do k=1,pver - do i = 1,ncol - cwp(i,k) = 1000.0_r8 *iclwpth(i,k) + 1000.0_r8 *iciwpth(i, k) - ficemr(i,k) = 1000.0_r8 * iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k))) - end do - end do - endif - - - do k=1,pver - do i=1,ncol - - ! Note from Andrew Conley: - ! Optics for RK no longer supported, This is constructed to get - ! close to bit for bit. Otherwise we could simply use liquid water path - !note that optical properties for ice valid only - !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 - - -end subroutine old_liq_get_rad_props_lw -!============================================================================== - -subroutine old_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp) - use physconst, only: gravit - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) - logical, intent(in) :: oldicewp - - real(r8) :: gicewp(pcols,pver) - real(r8) :: gliqwp(pcols,pver) - real(r8) :: cicewp(pcols,pver) - real(r8) :: cliqwp(pcols,pver) - real(r8) :: ficemr(pcols,pver) - real(r8) :: cwp(pcols,pver) - real(r8) :: cldtau(pcols,pver) - - real(r8), pointer, dimension(:,:) :: cldn - 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), pointer, dimension(:,:) :: iclwpth, iciwpth - - - ncol = state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, rei_idx, rei) - call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - if(oldicewp) then - do k=1,pver - do i = 1,ncol - gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path. - gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path. - cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. - cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. - ficemr(i,k) = state%q(i,k,ixcldice) / & - max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq))) - end do - end do - cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) - else - if (iclwp_idx<=0 .or. iciwp_idx<=0) then - call endrun('old_ice_get_rad_props_lw: oldicewp must be set to true since ICIWP and/or ICLWP were not found in pbuf') - endif - call pbuf_get_field(pbuf, iclwp_idx, iclwpth) - call pbuf_get_field(pbuf, iciwp_idx, iciwpth) - do k=1,pver - do i = 1,ncol - cwp(i,k) = 1000.0_r8 *iciwpth(i,k) + 1000.0_r8 *iclwpth(i,k) - ficemr(i,k) = 1000.0_r8*iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k))) - end do - end do - endif - - do k=1,pver - do i=1,ncol - - ! Note from Andrew Conley: - ! Optics for RK no longer supported, This is constructed to get - ! close to bit for bit. Otherwise we could simply use ice water path - !note that optical properties for ice valid only - !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 - - !if(oldicewp) then - ! call outfld('CIWPTH_OLD',cicewp(:,:)/1000,pcols,lchnk) - !else - ! call outfld('CIWPTH_OLD',iciwpth(:,:),pcols,lchnk) - !endif - !call outfld('CI_OD_LW_OLD',cldtau(:,:),pcols,lchnk) - -end subroutine old_ice_get_rad_props_lw -!============================================================================== - -subroutine cloud_total_vis_diag_out(lchnk, nnite, idxnite, tau, radsuffix) - - ! output total aerosol optical depth for the visible band - - use cam_history, only: outfld - use cam_history_support, only : fillvalue - - integer, intent(in) :: lchnk - integer, intent(in) :: nnite ! number of night columns - integer, intent(in) :: idxnite(nnite) ! local column indices of night columns - real(r8), intent(in) :: tau(:,:) - character(len=*), intent(in) :: radsuffix ! identifies whether the radiation call - ! is for the climate calc or a diagnostic calc - - ! Local variables - integer :: i - real(r8) :: tmp(pcols) - !----------------------------------------------------------------------------- - - ! compute total aerosol optical depth output where only daylight columns - tmp(:) = sum(tau(:,:), 2) - do i = 1, nnite - tmp(idxnite(i)) = fillvalue - end do - !call outfld('cloudOD_v'//trim(radsuffix), tmp, pcols, lchnk) - -end subroutine cloud_total_vis_diag_out - -!============================================================================== - -end module oldcloud diff --git a/src/physics/rrtmg/slingo.F90 b/src/physics/rrtmg/slingo.F90 deleted file mode 100644 index b9d68565ec..0000000000 --- a/src/physics/rrtmg/slingo.F90 +++ /dev/null @@ -1,409 +0,0 @@ -module slingo - -!------------------------------------------------------------------------------------------------ -! Implements Slingo Optics for MG/RRTMG for liquid clouds and -! a copy of the old cloud routine for reference -!------------------------------------------------------------------------------------------------ - -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pcols, pver, pverp -use physics_types, only: physics_state -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx -use radconstants, only: nswbands, nlwbands, idx_sw_diag, idx_lw_diag, get_sw_spectral_boundaries -use cam_abortutils, only: endrun -use cam_history, only: outfld - -implicit none -private -save - -public :: & - slingo_rad_props_init, & - cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols - cloud_rad_props_get_lw, & ! return LW optical props of total bulk aerosols - slingo_liq_get_rad_props_lw, & - slingo_liq_optics_sw - -! Minimum cloud amount (as a fraction of the grid-box area) to -! distinguish from clear sky -! - real(r8) cldmin - parameter (cldmin = 1.0e-80_r8) -! -! Decimal precision of cloud amount (0 -> preserve full resolution; -! 10^-n -> preserve n digits of cloud amount) -! - real(r8) cldeps - parameter (cldeps = 0.0_r8) - -! -! indexes into pbuf for optical parameters of MG clouds -! - integer :: iclwp_idx = 0 - integer :: iciwp_idx = 0 - integer :: cld_idx = 0 - integer :: rel_idx = 0 - integer :: rei_idx = 0 - -! indexes into constituents for old optics - integer :: & - ixcldliq, & ! cloud liquid water index - ixcldice ! cloud liquid water index - - -!============================================================================== -contains -!============================================================================== - -subroutine slingo_rad_props_init() - -! use cam_history, only: addfld - use netcdf - use spmd_utils, only: masterproc - use ioFileMod, only: getfil - use cam_logfile, only: iulog - use error_messages, only: handle_ncerr -#if ( defined SPMD ) - use mpishorthand -#endif - use constituents, only: cnst_get_ind - - integer :: err - - iciwp_idx = pbuf_get_index('ICIWP',errcode=err) - iclwp_idx = pbuf_get_index('ICLWP',errcode=err) - cld_idx = pbuf_get_index('CLD') - rel_idx = pbuf_get_index('REL') - rei_idx = pbuf_get_index('REI') - - ! old optics - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - - !call addfld ('CLWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','old In Cloud Liquid Water Path', sampling_seq='rad_lwsw') - !call addfld ('KEXT_OLD',(/ 'lev' /),'I','m^2/kg','old extinction') - !call addfld ('CLDOD_OLD',(/ 'lev' /),'I','1','old liquid OD') - !call addfld ('REL_OLD',(/ 'lev' /),'I','1','old liquid effective radius (liquid)') - - !call addfld ('CLWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Liquid Water Path', sampling_seq='rad_lwsw') - !call addfld ('KEXT_NEW',(/ 'lev' /),'I','m^2/kg','extinction') - !call addfld ('CLDOD_NEW',(/ 'lev' /),'I','1','liquid OD') - - !call addfld('CIWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path', sampling_seq='rad_lwsw') - !call addfld('CIWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path (old)', sampling_seq='rad_lwsw') - - return - -end subroutine slingo_rad_props_init - -!============================================================================== - -subroutine cloud_rad_props_get_sw(state, pbuf, & - tau, tau_w, tau_w_g, tau_w_f,& - diagnosticindex) - -! return totaled (across all species) layer tau, omega, g, f -! for all spectral interval for aerosols affecting the climate - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - integer, optional, intent(in) :: diagnosticindex ! index (if present) to radiation diagnostic information - - real(r8), intent(out) :: tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8), intent(out) :: tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8), intent(out) :: tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8), intent(out) :: tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - ! Local variables - - integer :: ncol - integer :: lchnk - integer :: k, i ! lev and daycolumn indices - integer :: iswband ! sw band indices - - real(r8) :: liq_tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8) :: liq_tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - call slingo_liq_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f, oldliqwp=.true. ) - -end subroutine cloud_rad_props_get_sw -!============================================================================== - -subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldliq, oldice, oldcloud) - -! Purpose: Compute cloud longwave absorption optical depth -! cloud_rad_props_get_lw() is called by radlw() - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer - integer, optional, intent(in) :: diagnosticindex - logical, optional, intent(in) :: oldliq ! use old liquid optics - logical, optional, intent(in) :: oldice ! use old ice optics - logical, optional, intent(in) :: oldcloud ! use old optics for both (b4b) - - ! Local variables - - integer :: bnd_idx ! LW band index - integer :: i ! column index - integer :: k ! lev index - integer :: ncol ! number of columns - integer :: lchnk - - ! rad properties for liquid clouds - real(r8) :: liq_tau_abs_od(nlwbands,pcols,pver) ! liquid cloud absorption optical depth - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - ! compute optical depths cld_absod - cld_abs_od = 0._r8 - - call slingo_liq_get_rad_props_lw(state, pbuf, liq_tau_abs_od, oldliqwp=.true.) - - cld_abs_od(:,1:ncol,:) = liq_tau_abs_od(:,1:ncol,:) - -end subroutine cloud_rad_props_get_lw - -!============================================================================== -! Private methods -!============================================================================== - - -subroutine slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp) - - use physconst, only: gravit - - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - logical, intent(in) :: oldliqwp - - real(r8), pointer, dimension(:,:) :: rel - real(r8), pointer, dimension(:,:) :: cldn - real(r8), pointer, dimension(:,:) :: tmpptr - real(r8), dimension(pcols,pver) :: cliqwp - real(r8), dimension(nswbands) :: wavmin - real(r8), dimension(nswbands) :: wavmax - - ! Minimum cloud amount (as a fraction of the grid-box area) to - ! distinguish from clear sky - real(r8), parameter :: cldmin = 1.0e-80_r8 - - ! Decimal precision of cloud amount (0 -> preserve full resolution; - ! 10^-n -> preserve n digits of cloud amount) - real(r8), parameter :: cldeps = 0.0_r8 - - ! A. Slingo's data for cloud particle radiative properties (from 'A GCM - ! Parameterization for the Shortwave Properties of Water Clouds' JAS - ! vol. 46 may 1989 pp 1419-1427) - real(r8) :: abarl(4) = & ! A coefficient for extinction optical depth - (/ 2.817e-02_r8, 2.682e-02_r8,2.264e-02_r8,1.281e-02_r8/) - real(r8) :: bbarl(4) = & ! B coefficient for extinction optical depth - (/ 1.305_r8 , 1.346_r8 ,1.454_r8 ,1.641_r8 /) - real(r8) :: cbarl(4) = & ! C coefficient for single scat albedo - (/-5.62e-08_r8 ,-6.94e-06_r8 ,4.64e-04_r8 ,0.201_r8 /) - real(r8) :: dbarl(4) = & ! D coefficient for single scat albedo - (/ 1.63e-07_r8 , 2.35e-05_r8 ,1.24e-03_r8 ,7.56e-03_r8 /) - real(r8) :: ebarl(4) = & ! E coefficient for asymmetry parameter - (/ 0.829_r8 , 0.794_r8 ,0.754_r8 ,0.826_r8 /) - real(r8) :: fbarl(4) = & ! F coefficient for asymmetry parameter - (/ 2.482e-03_r8, 4.226e-03_r8,6.560e-03_r8,4.353e-03_r8/) - - real(r8) :: abarli ! A coefficient for current spectral band - real(r8) :: bbarli ! B coefficient for current spectral band - real(r8) :: cbarli ! C coefficient for current spectral band - real(r8) :: dbarli ! D coefficient for current spectral band - real(r8) :: ebarli ! E coefficient for current spectral band - real(r8) :: fbarli ! F coefficient for current spectral band - - ! Caution... A. Slingo recommends no less than 4.0 micro-meters nor - ! greater than 20 micro-meters - - integer :: ns, i, k, indxsl, Nday - integer :: i_rel, lchnk, icld, itim_old - real(r8) :: tmp1l, tmp2l, tmp3l, g - real(r8) :: kext(pcols,pver) - real(r8), pointer, dimension(:,:) :: iclwpth - - Nday = state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, rel_idx, rel) - - if (oldliqwp) then - do k=1,pver - do i = 1,Nday - cliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/(gravit*max(0.01_r8,cldn(i,k))) - end do - end do - else - if (iclwp_idx<=0) then - call endrun('slingo_liq_optics_sw: oldliqwp must be set to true since ICLWP was not found in pbuf') - endif - ! The following is the eventual target specification for in cloud liquid water path. - call pbuf_get_field(pbuf, iclwp_idx, tmpptr) - cliqwp = tmpptr - endif - - call get_sw_spectral_boundaries(wavmin,wavmax,'microns') - - do ns = 1, nswbands - ! Set index for cloud particle properties based on the wavelength, - ! according to A. Slingo (1989) equations 1-3: - ! Use index 1 (0.25 to 0.69 micrometers) for visible - ! Use index 2 (0.69 - 1.19 micrometers) for near-infrared - ! Use index 3 (1.19 to 2.38 micrometers) for near-infrared - ! Use index 4 (2.38 to 4.00 micrometers) for near-infrared - if(wavmax(ns) <= 0.7_r8) then - indxsl = 1 - else if(wavmax(ns) <= 1.25_r8) then - indxsl = 2 - else if(wavmax(ns) <= 2.38_r8) then - indxsl = 3 - else if(wavmax(ns) > 2.38_r8) then - indxsl = 4 - end if - - ! Set cloud extinction optical depth, single scatter albedo, - ! asymmetry parameter, and forward scattered fraction: - abarli = abarl(indxsl) - bbarli = bbarl(indxsl) - cbarli = cbarl(indxsl) - dbarli = dbarl(indxsl) - ebarli = ebarl(indxsl) - fbarli = fbarl(indxsl) - - do k=1,pver - do i=1,Nday - - ! note that optical properties for liquid valid only - ! in range of 4.2 > rel > 16 micron (Slingo 89) - if (cldn(i,k) >= cldmin .and. cldn(i,k) >= cldeps) then - tmp1l = abarli + bbarli/min(max(4.2_r8,rel(i,k)),16._r8) - liq_tau(ns,i,k) = 1000._r8*cliqwp(i,k)*tmp1l - else - liq_tau(ns,i,k) = 0.0_r8 - endif - - tmp2l = 1._r8 - cbarli - dbarli*min(max(4.2_r8,rel(i,k)),16._r8) - tmp3l = fbarli*min(max(4.2_r8,rel(i,k)),16._r8) - ! Do not let single scatter albedo be 1. Delta-eddington solution - ! for non-conservative case has different analytic form from solution - ! for conservative case, and raddedmx is written for non-conservative case. - liq_tau_w(ns,i,k) = liq_tau(ns,i,k) * min(tmp2l,.999999_r8) - g = ebarli + tmp3l - liq_tau_w_g(ns,i,k) = liq_tau_w(ns,i,k) * g - liq_tau_w_f(ns,i,k) = liq_tau_w(ns,i,k) * g * g - - end do ! End do i=1,Nday - end do ! End do k=1,pver - end do ! nswbands - - !call outfld('CL_OD_SW_OLD',liq_tau(idx_sw_diag,:,:), pcols, lchnk) - !call outfld('REL_OLD',rel(:,:), pcols, lchnk) - !call outfld('CLWPTH_OLD',cliqwp(:,:), pcols, lchnk) - !call outfld('KEXT_OLD',kext(:,:), pcols, lchnk) - - -end subroutine slingo_liq_optics_sw - -subroutine slingo_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp) - use physconst, only: gravit - - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) - logical, intent(in) :: oldliqwp - - real(r8) :: gicewp(pcols,pver) - real(r8) :: gliqwp(pcols,pver) - real(r8) :: cicewp(pcols,pver) - real(r8) :: cliqwp(pcols,pver) - real(r8) :: ficemr(pcols,pver) - real(r8) :: cwp(pcols,pver) - real(r8) :: cldtau(pcols,pver) - - real(r8), pointer, dimension(:,:) :: cldn - real(r8), pointer, dimension(:,:) :: rei - integer :: ncol, icld, itim_old, i_rei, 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), pointer, dimension(:,:) :: iclwpth, iciwpth - - ncol=state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, rei_idx, rei) - call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - if (oldliqwp) then - do k=1,pver - do i = 1,ncol - gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path. - gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path. - cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path. - cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path. - ficemr(i,k) = state%q(i,k,ixcldice) / & - max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq))) - end do - end do - cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver) - else - if (iclwp_idx<=0 .or. iciwp_idx<=0) then - call endrun('slingo_liq_get_rad_props_lw: oldliqwp must be set to true since ICIWP and/or ICLWP were not found in pbuf') - endif - call pbuf_get_field(pbuf, iclwp_idx, iclwpth) - call pbuf_get_field(pbuf, iciwp_idx, iciwpth) - do k=1,pver - do i = 1,ncol - cwp (i,k) = 1000.0_r8 * iclwpth(i,k) + 1000.0_r8 * iciwpth(i, k) - ficemr(i,k) = 1000.0_r8 * iciwpth(i,k)/(max(1.e-18_r8, cwp(i,k))) - end do - end do - endif - - - do k=1,pver - do i=1,ncol - - ! Note from Andrew Conley: - ! Optics for RK no longer supported, This is constructed to get - ! close to bit for bit. Otherwise we could simply use liquid water path - !note that optical properties for ice valid only - !in range of 13 > rei > 130 micron (Ebert and Curry 92) - kabs = kabsl*(1._r8-ficemr(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 - - -end subroutine slingo_liq_get_rad_props_lw - -end module slingo From 4b1dc77d314600c1eb22099cdec0db695dc17e1b Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Sun, 17 Sep 2023 19:39:07 -0400 Subject: [PATCH 29/53] bugfix for simple models; cleanup in cloud optics code --- src/physics/cam/ebert_curry.F90 | 161 +++------------------------- src/physics/cam/slingo.F90 | 90 +--------------- src/physics/simple/radconstants.F90 | 17 ++- 3 files changed, 30 insertions(+), 238 deletions(-) diff --git a/src/physics/cam/ebert_curry.F90 b/src/physics/cam/ebert_curry.F90 index c04a864ef0..e218b8e7b3 100644 --- a/src/physics/cam/ebert_curry.F90 +++ b/src/physics/cam/ebert_curry.F90 @@ -1,15 +1,14 @@ module ebert_curry -!------------------------------------------------------------------------------------------------ -!------------------------------------------------------------------------------------------------ use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pcols, pver, pverp +use physconst, only: gravit +use ppgrid, only: pcols, pver use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx +use constituents, only: cnst_get_ind use radconstants, only: nswbands, nlwbands, get_sw_spectral_boundaries use cam_abortutils, only: endrun -use cam_history, only: outfld implicit none private @@ -17,41 +16,21 @@ module ebert_curry public :: & ec_rad_props_init, & - cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols - cloud_rad_props_get_lw, & ! return LW optical props of total bulk aerosols ec_ice_optics_sw, & ec_ice_get_rad_props_lw real(r8), public, parameter:: scalefactor = 1._r8 !500._r8/917._r8 -! Minimum cloud amount (as a fraction of the grid-box area) to -! distinguish from clear sky -! - real(r8) cldmin - parameter (cldmin = 1.0e-80_r8) -! -! Decimal precision of cloud amount (0 -> preserve full resolution; -! 10^-n -> preserve n digits of cloud amount) -! - real(r8) cldeps - parameter (cldeps = 0.0_r8) - -! -! indexes into pbuf for optical parameters of MG clouds -! - integer :: dei_idx = 0 - integer :: mu_idx = 0 - integer :: lambda_idx = 0 - integer :: iciwp_idx = 0 - integer :: iclwp_idx = 0 - integer :: cld_idx = 0 - integer :: rei_idx = 0 - -! indexes into constituents for old optics - integer :: & - ixcldice, & ! cloud ice water index - ixcldliq ! cloud liquid water index +! indices into pbuf +integer :: iciwp_idx = 0 +integer :: iclwp_idx = 0 +integer :: cld_idx = 0 +integer :: rei_idx = 0 + +! indices into constituents for old optics +integer :: ixcldice ! cloud ice water index +integer :: ixcldliq ! cloud liquid water index !============================================================================== @@ -60,17 +39,6 @@ module ebert_curry subroutine ec_rad_props_init() -! use cam_history, only: addfld - use netcdf - use spmd_utils, only: masterproc - use ioFileMod, only: getfil - use cam_logfile, only: iulog - use error_messages, only: handle_ncerr -#if ( defined SPMD ) - use mpishorthand -#endif - use constituents, only: cnst_get_ind - integer :: err iciwp_idx = pbuf_get_index('ICIWP',errcode=err) @@ -82,115 +50,13 @@ subroutine ec_rad_props_init() call cnst_get_ind('CLDICE', ixcldice) call cnst_get_ind('CLDLIQ', ixcldliq) - !call addfld ('CLWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','old In Cloud Liquid Water Path', sampling_seq='rad_lwsw') - !call addfld ('KEXT_OLD',(/ 'lev' /),'I','m^2/kg','old extinction') - !call addfld ('CLDOD_OLD',(/ 'lev' /),'I','1','old liquid OD') - !call addfld ('REL_OLD',(/ 'lev' /),'I','1','old liquid effective radius (liquid)') - - !call addfld ('CLWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Liquid Water Path', sampling_seq='rad_lwsw') - !call addfld ('KEXT_NEW',(/ 'lev' /),'I','m^2/kg','extinction') - !call addfld ('CLDOD_NEW',(/ 'lev' /),'I','1','liquid OD') - - !call addfld('CIWPTH_NEW',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path', sampling_seq='rad_lwsw') - !call addfld('CIWPTH_OLD',(/ 'lev' /), 'I','Kg/m2','In Cloud Ice Water Path (old)', sampling_seq='rad_lwsw') - - return - end subroutine ec_rad_props_init !============================================================================== -subroutine cloud_rad_props_get_sw(state, pbuf, & - tau, tau_w, tau_w_g, tau_w_f,& - diagnosticindex, oldliq, oldice) - -! return totaled (across all species) layer tau, omega, g, f -! for all spectral interval for aerosols affecting the climate - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - integer, optional, intent(in) :: diagnosticindex ! index (if present) to radiation diagnostic information - - real(r8), intent(out) :: tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8), intent(out) :: tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8), intent(out) :: tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8), intent(out) :: tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - logical, optional, intent(in) :: oldliq,oldice - - ! Local variables - - integer :: ncol - integer :: lchnk - integer :: k, i ! lev and daycolumn indices - integer :: iswband ! sw band indices - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - ! initialize to conditions that would cause failure - tau (:,:,:) = -100._r8 - tau_w (:,:,:) = -100._r8 - tau_w_g (:,:,:) = -100._r8 - tau_w_f (:,:,:) = -100._r8 - - ! initialize layers to accumulate od's - tau (:,1:ncol,:) = 0._r8 - tau_w (:,1:ncol,:) = 0._r8 - tau_w_g(:,1:ncol,:) = 0._r8 - tau_w_f(:,1:ncol,:) = 0._r8 - - call ec_ice_optics_sw (state, pbuf, tau, tau_w, tau_w_g, tau_w_f, oldicewp=.true.) - -end subroutine cloud_rad_props_get_sw -!============================================================================== - -subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldliq, oldice, oldcloud) - -! Purpose: Compute cloud longwave absorption optical depth -! cloud_rad_props_get_lw() is called by radlw() - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer - integer, optional, intent(in) :: diagnosticindex - logical, optional, intent(in) :: oldliq ! use old liquid optics - logical, optional, intent(in) :: oldice ! use old ice optics - logical, optional, intent(in) :: oldcloud ! use old optics for both (b4b) - - ! Local variables - - integer :: bnd_idx ! LW band index - integer :: i ! column index - integer :: k ! lev index - integer :: ncol ! number of columns - integer :: lchnk - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - ! compute optical depths cld_absod - cld_abs_od = 0._r8 - - call ec_ice_get_rad_props_lw(state, pbuf, cld_abs_od, oldicewp=.true.) - -end subroutine cloud_rad_props_get_lw - -!============================================================================== -! Private methods -!============================================================================== - subroutine ec_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp) - use physconst, only: gravit - - type(physics_state), intent(in) :: state + type(physics_state), intent(in) :: state type(physics_buffer_desc), pointer :: pbuf(:) real(r8),intent(out) :: ice_tau (nswbands,pcols,pver) ! extinction optical depth @@ -311,7 +177,6 @@ end subroutine ec_ice_optics_sw !============================================================================== subroutine ec_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp) - use physconst, only: gravit type(physics_state), intent(in) :: state type(physics_buffer_desc),pointer :: pbuf(:) diff --git a/src/physics/cam/slingo.F90 b/src/physics/cam/slingo.F90 index 64d614365e..98018afa0f 100644 --- a/src/physics/cam/slingo.F90 +++ b/src/physics/cam/slingo.F90 @@ -6,12 +6,12 @@ module slingo !------------------------------------------------------------------------------------------------ use shr_kind_mod, only: r8 => shr_kind_r8 +use physconst, only: gravit use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx use radconstants, only: nswbands, nlwbands, get_sw_spectral_boundaries use cam_abortutils, only: endrun -use cam_history, only: outfld implicit none private @@ -19,8 +19,6 @@ module slingo public :: & slingo_rad_props_init, & - cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols - cloud_rad_props_get_lw, & ! return LW optical props of total bulk aerosols slingo_liq_get_rad_props_lw, & slingo_liq_optics_sw @@ -84,94 +82,9 @@ end subroutine slingo_rad_props_init !============================================================================== -subroutine cloud_rad_props_get_sw(state, pbuf, & - tau, tau_w, tau_w_g, tau_w_f,& - diagnosticindex) - -! return totaled (across all species) layer tau, omega, g, f -! for all spectral interval for aerosols affecting the climate - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - integer, optional, intent(in) :: diagnosticindex ! index (if present) to radiation diagnostic information - - real(r8), intent(out) :: tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8), intent(out) :: tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8), intent(out) :: tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8), intent(out) :: tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - ! Local variables - - integer :: ncol - integer :: lchnk - integer :: k, i ! lev and daycolumn indices - integer :: iswband ! sw band indices - - real(r8) :: liq_tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8) :: liq_tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - call slingo_liq_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f, oldliqwp=.true. ) - -end subroutine cloud_rad_props_get_sw -!============================================================================== - -subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldliq, oldice, oldcloud) - -! Purpose: Compute cloud longwave absorption optical depth -! cloud_rad_props_get_lw() is called by radlw() - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer - integer, optional, intent(in) :: diagnosticindex - logical, optional, intent(in) :: oldliq ! use old liquid optics - logical, optional, intent(in) :: oldice ! use old ice optics - logical, optional, intent(in) :: oldcloud ! use old optics for both (b4b) - - ! Local variables - - integer :: bnd_idx ! LW band index - integer :: i ! column index - integer :: k ! lev index - integer :: ncol ! number of columns - integer :: lchnk - - ! rad properties for liquid clouds - real(r8) :: liq_tau_abs_od(nlwbands,pcols,pver) ! liquid cloud absorption optical depth - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - ! compute optical depths cld_absod - cld_abs_od = 0._r8 - - call slingo_liq_get_rad_props_lw(state, pbuf, liq_tau_abs_od, oldliqwp=.true.) - - cld_abs_od(:,1:ncol,:) = liq_tau_abs_od(:,1:ncol,:) - -end subroutine cloud_rad_props_get_lw - -!============================================================================== -! Private methods -!============================================================================== - subroutine slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp) - use physconst, only: gravit - type(physics_state), intent(in) :: state type(physics_buffer_desc), pointer :: pbuf(:) @@ -307,7 +220,6 @@ subroutine slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, li end subroutine slingo_liq_optics_sw subroutine slingo_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp) - use physconst, only: gravit type(physics_state), intent(in) :: state type(physics_buffer_desc),pointer :: pbuf(:) diff --git a/src/physics/simple/radconstants.F90 b/src/physics/simple/radconstants.F90 index 60585713d6..4476dc6669 100644 --- a/src/physics/simple/radconstants.F90 +++ b/src/physics/simple/radconstants.F90 @@ -17,7 +17,7 @@ module radconstants integer, parameter, public :: idx_uv_diag = 1 public :: rad_gas_index -public :: get_lw_spectral_boundaries +public :: get_lw_spectral_boundaries, get_sw_spectral_boundaries integer, public, parameter :: gasnamelength = 1 integer, public, parameter :: nradgas = 1 @@ -37,6 +37,7 @@ integer function rad_gas_index(gasname) end function rad_gas_index !------------------------------------------------------------------------------ + subroutine get_lw_spectral_boundaries(low_boundaries, high_boundaries, units) ! stub should not be called @@ -47,4 +48,18 @@ subroutine get_lw_spectral_boundaries(low_boundaries, high_boundaries, units) end subroutine get_lw_spectral_boundaries +!------------------------------------------------------------------------------ + +subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) + ! stub should not be called + + real(r8), intent(out) :: low_boundaries(nswbands), high_boundaries(nswbands) + character(*), intent(in) :: units ! requested units + + call endrun('get_sw_spectral_boundaries: ERROR: this is a stub') + +end subroutine get_sw_spectral_boundaries + +!------------------------------------------------------------------------------ + end module radconstants From 1a047e0f4eae8341df80097d633c28740aa6ef04 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 19 Sep 2023 17:36:03 -0400 Subject: [PATCH 30/53] more cleanup in cloud optics code --- src/physics/cam/cloud_rad_props.F90 | 309 +++++++++--------------- src/physics/cam/ebert_curry.F90 | 2 + src/physics/cam/oldcloud.F90 | 355 ++-------------------------- src/physics/cam/slingo.F90 | 39 +-- src/physics/rrtmgp/radiation.F90 | 6 +- 5 files changed, 150 insertions(+), 561 deletions(-) diff --git a/src/physics/cam/cloud_rad_props.F90 b/src/physics/cam/cloud_rad_props.F90 index 1ba4f200a3..1e518a47d7 100644 --- a/src/physics/cam/cloud_rad_props.F90 +++ b/src/physics/cam/cloud_rad_props.F90 @@ -7,16 +7,22 @@ module cloud_rad_props use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx +use constituents, only: cnst_get_ind use radconstants, only: nswbands, nlwbands, idx_sw_diag -use cam_abortutils, only: endrun use rad_constituents, only: iceopticsfile, liqopticsfile -use oldcloud, only: oldcloud_lw, old_liq_get_rad_props_lw, old_ice_get_rad_props_lw, oldcloud_init +use oldcloud, only: oldcloud_init, oldcloud_lw, & + old_liq_get_rad_props_lw, old_ice_get_rad_props_lw + -use ebert_curry, only: scalefactor -use cam_logfile, only: iulog +use slingo, only: slingo_rad_props_init +use ebert_curry, only: ec_rad_props_init, scalefactor use interpolate_data, only: interp_type, lininterp_init, lininterp, & - extrap_method_bndry, lininterp_finish + extrap_method_bndry, lininterp_finish + +use cam_logfile, only: iulog +use cam_abortutils, only: endrun + implicit none private @@ -24,16 +30,15 @@ module cloud_rad_props public :: & cloud_rad_props_init, & - cloud_rad_props_get_sw, & ! return SW optical props of total bulk aerosols - cloud_rad_props_get_lw, & ! return LW optical props of total bulk aerosols + cloud_rad_props_get_lw, & ! return LW optical props for old cloud optics get_ice_optics_sw, & ! return Mitchell SW ice radiative properties ice_cloud_get_rad_props_lw, & ! return Mitchell LW ice radiative properties get_liquid_optics_sw, & ! return Conley SW radiative properties liquid_cloud_get_rad_props_lw, & ! return Conley LW radiative properties - grau_cloud_get_rad_props_lw, & - get_grau_optics_sw, & + get_snow_optics_sw, & snow_cloud_get_rad_props_lw, & - get_snow_optics_sw + get_grau_optics_sw, & + grau_cloud_get_rad_props_lw integer :: nmu, nlambda @@ -51,24 +56,21 @@ module cloud_rad_props real(r8), allocatable :: asm_sw_ice(:,:) real(r8), allocatable :: abs_lw_ice(:,:) -! ! indexes into pbuf for optical parameters of MG clouds -! - integer :: i_dei=0 - integer :: i_mu=0 - integer :: i_lambda=0 - integer :: i_iciwp=0 - integer :: i_iclwp=0 - integer :: i_des=0 - integer :: i_icswp=0 - integer :: i_degrau=0 - integer :: i_icgrauwp=0 +integer :: i_dei=0 +integer :: i_mu=0 +integer :: i_lambda=0 +integer :: i_iciwp=0 +integer :: i_iclwp=0 +integer :: i_des=0 +integer :: i_icswp=0 +integer :: i_degrau=0 +integer :: i_icgrauwp=0 ! indexes into constituents for old optics - integer :: & - ixcldice, & ! cloud ice water index - ixcldliq ! cloud liquid water index - +integer :: & + ixcldice, & ! cloud ice water index + ixcldliq ! cloud liquid water index !============================================================================== contains @@ -83,9 +85,6 @@ subroutine cloud_rad_props_init() #if ( defined SPMD ) use mpishorthand #endif - use constituents, only: cnst_get_ind - use slingo, only: slingo_rad_props_init - use ebert_curry, only: ec_rad_props_init, scalefactor character(len=256) :: liquidfile character(len=256) :: icefile @@ -199,7 +198,7 @@ subroutine cloud_rad_props_init() call mpibcast(asm_sw_liq, nmu*nlambda*nswbands, mpir8, 0, mpicom, ierr) call mpibcast(abs_lw_liq, nmu*nlambda*nlwbands, mpir8, 0, mpicom, ierr) #endif - ! I forgot to convert kext from m^2/Volume to m^2/Kg + ! Convert kext from m^2/Volume to m^2/Kg ext_sw_liq = ext_sw_liq / 0.9970449e3_r8 abs_lw_liq = abs_lw_liq / 0.9970449e3_r8 @@ -283,124 +282,34 @@ end subroutine cloud_rad_props_init !============================================================================== -subroutine cloud_rad_props_get_sw(state, pbuf, & - tau, tau_w, tau_w_g, tau_w_f,& - diagnosticindex, oldliq, oldice) - -! return totaled (across all species) layer tau, omega, g, f -! for all spectral interval for aerosols affecting the climate - - ! Arguments - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - integer, optional, intent(in) :: diagnosticindex ! index (if present) to radiation diagnostic information - - real(r8), intent(out) :: tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8), intent(out) :: tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8), intent(out) :: tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8), intent(out) :: tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - logical, optional, intent(in) :: oldliq,oldice - - ! Local variables - - integer :: ncol - integer :: lchnk - integer :: k, i ! lev and daycolumn indices - integer :: iswband ! sw band indices - - ! optical props for each aerosol - real(r8), pointer :: h_ext(:,:) - real(r8), pointer :: h_ssa(:,:) - real(r8), pointer :: h_asm(:,:) - real(r8), pointer :: n_ext(:) - real(r8), pointer :: n_ssa(:) - real(r8), pointer :: n_asm(:) - - ! rad properties for liquid clouds - real(r8) :: liq_tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8) :: liq_tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - ! rad properties for ice clouds - real(r8) :: ice_tau (nswbands,pcols,pver) ! aerosol extinction optical depth - real(r8) :: ice_tau_w (nswbands,pcols,pver) ! aerosol single scattering albedo * tau - real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! aerosol assymetry parameter * tau * w - real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! aerosol forward scattered fraction * tau * w - - !----------------------------------------------------------------------------- - - ncol = state%ncol - lchnk = state%lchnk - - ! initialize to conditions that would cause failure - tau (:,:,:) = -100._r8 - tau_w (:,:,:) = -100._r8 - tau_w_g (:,:,:) = -100._r8 - tau_w_f (:,:,:) = -100._r8 - - ! initialize layers to accumulate od's - tau (:,1:ncol,:) = 0._r8 - tau_w (:,1:ncol,:) = 0._r8 - tau_w_g(:,1:ncol,:) = 0._r8 - tau_w_f(:,1:ncol,:) = 0._r8 - - - call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) - - call get_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) - - tau (:,1:ncol,:) = liq_tau (:,1:ncol,:) + ice_tau (:,1:ncol,:) - tau_w (:,1:ncol,:) = liq_tau_w (:,1:ncol,:) + ice_tau_w (:,1:ncol,:) - tau_w_g(:,1:ncol,:) = liq_tau_w_g(:,1:ncol,:) + ice_tau_w_g(:,1:ncol,:) - tau_w_f(:,1:ncol,:) = liq_tau_w_f(:,1:ncol,:) + ice_tau_w_f(:,1:ncol,:) - -end subroutine cloud_rad_props_get_sw -!============================================================================== - -subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, diagnosticindex, oldliq, oldice, oldcloud) +subroutine cloud_rad_props_get_lw(state, pbuf, cld_abs_od, oldliq, oldice, oldcloud) -! Purpose: Compute cloud longwave absorption optical depth -! cloud_rad_props_get_lw() is called by radlw() + ! Purpose: Compute cloud longwave absorption optical depth ! Arguments type(physics_state), intent(in) :: state type(physics_buffer_desc),pointer:: pbuf(:) real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer - integer, optional, intent(in) :: diagnosticindex logical, optional, intent(in) :: oldliq ! use old liquid optics logical, optional, intent(in) :: oldice ! use old ice optics logical, optional, intent(in) :: oldcloud ! use old optics for both (b4b) ! Local variables - - integer :: bnd_idx ! LW band index - integer :: i ! column index - integer :: k ! lev index integer :: ncol ! number of columns - integer :: lchnk ! rad properties for liquid clouds real(r8) :: liq_tau_abs_od(nlwbands,pcols,pver) ! liquid cloud absorption optical depth ! rad properties for ice clouds real(r8) :: ice_tau_abs_od(nlwbands,pcols,pver) ! ice cloud absorption optical depth - !----------------------------------------------------------------------------- ncol = state%ncol - lchnk = state%lchnk - ! compute optical depths cld_absod cld_abs_od = 0._r8 if(present(oldcloud))then if(oldcloud) then - ! make diagnostic calls to these first to output ice and liq OD's - !call old_liq_get_rad_props_lw(state, pbuf, liq_tau_abs_od, oldliqwp=.false.) - !call old_ice_get_rad_props_lw(state, pbuf, ice_tau_abs_od, oldicewp=.false.) - ! This affects climate (cld_abs_od) call oldcloud_lw(state,pbuf,cld_abs_od,oldwp=.false.) return endif @@ -432,6 +341,29 @@ end subroutine cloud_rad_props_get_lw !============================================================================== +subroutine get_ice_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) + type(physics_state), intent(in) :: state + type(physics_buffer_desc),pointer :: pbuf(:) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + + real(r8), pointer :: iciwpth(:,:), dei(:,:) + + ! Get relevant pbuf fields, and interpolate optical properties from + ! the lookup tables. + call pbuf_get_field(pbuf, i_iciwp, iciwpth) + call pbuf_get_field(pbuf, i_dei, dei) + + call interpolate_ice_optics_sw(state%ncol, iciwpth, dei, tau, tau_w, & + tau_w_g, tau_w_f) + +end subroutine get_ice_optics_sw + +!============================================================================== + subroutine get_snow_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) type(physics_state), intent(in) :: state type(physics_buffer_desc),pointer :: pbuf(:) @@ -492,82 +424,6 @@ subroutine get_grau_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) end subroutine get_grau_optics_sw -!============================================================================== -! Private methods -!============================================================================== - -subroutine get_ice_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - - real(r8), pointer :: iciwpth(:,:), dei(:,:) - - ! Get relevant pbuf fields, and interpolate optical properties from - ! the lookup tables. - call pbuf_get_field(pbuf, i_iciwp, iciwpth) - call pbuf_get_field(pbuf, i_dei, dei) - - call interpolate_ice_optics_sw(state%ncol, iciwpth, dei, tau, tau_w, & - tau_w_g, tau_w_f) - -end subroutine get_ice_optics_sw - -!============================================================================== - -subroutine interpolate_ice_optics_sw(ncol, iciwpth, dei, tau, tau_w, & - tau_w_g, tau_w_f) - - integer, intent(in) :: ncol - real(r8), intent(in) :: iciwpth(pcols,pver) - real(r8), intent(in) :: dei(pcols,pver) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - - type(interp_type) :: dei_wgts - - integer :: i, k, swband - real(r8) :: ext(nswbands), ssa(nswbands), asm(nswbands) - - do k = 1,pver - do i = 1,ncol - if( iciwpth(i,k) < 1.e-80_r8 .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 - tau_w_g(:,i,k) = 0._r8 - tau_w_f(:,i,k) = 0._r8 - else - ! for each cell interpolate to find weights in g_d_eff grid. - call lininterp_init(g_d_eff, n_g_d, dei(i:i,k), 1, & - extrap_method_bndry, dei_wgts) - ! interpolate into grid and extract radiative properties - do swband = 1, nswbands - call lininterp(ext_sw_ice(:,swband), n_g_d, & - ext(swband:swband), 1, dei_wgts) - call lininterp(ssa_sw_ice(:,swband), n_g_d, & - ssa(swband:swband), 1, dei_wgts) - call lininterp(asm_sw_ice(:,swband), n_g_d, & - asm(swband:swband), 1, dei_wgts) - end do - tau (:,i,k) = iciwpth(i,k) * ext - tau_w (:,i,k) = tau(:,i,k) * ssa - tau_w_g(:,i,k) = tau_w(:,i,k) * asm - tau_w_f(:,i,k) = tau_w_g(:,i,k) * asm - call lininterp_finish(dei_wgts) - endif - enddo - enddo - -end subroutine interpolate_ice_optics_sw - !============================================================================== subroutine get_liquid_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) @@ -581,9 +437,8 @@ subroutine get_liquid_optics_sw(state, pbuf, tau, tau_w, tau_w_g, tau_w_f) real(r8), pointer, dimension(:,:) :: lamc, pgam, iclwpth real(r8), dimension(pcols,pver) :: kext - integer i,k,swband,lchnk,ncol + integer i,k,swband, ncol - lchnk = state%lchnk ncol = state%ncol @@ -614,14 +469,13 @@ subroutine liquid_cloud_get_rad_props_lw(state, pbuf, abs_od) type(physics_buffer_desc),pointer :: pbuf(:) real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) - integer :: lchnk, ncol + integer :: ncol real(r8), pointer, dimension(:,:) :: lamc, pgam, iclwpth integer lwband, i, k abs_od = 0._r8 - lchnk = state%lchnk ncol = state%ncol call pbuf_get_field(pbuf, i_lambda, lamc) @@ -699,6 +553,59 @@ subroutine ice_cloud_get_rad_props_lw(state, pbuf, abs_od) end subroutine ice_cloud_get_rad_props_lw +!============================================================================== +! Private methods +!============================================================================== + +subroutine interpolate_ice_optics_sw(ncol, iciwpth, dei, tau, tau_w, & + tau_w_g, tau_w_f) + + integer, intent(in) :: ncol + real(r8), intent(in) :: iciwpth(pcols,pver) + real(r8), intent(in) :: dei(pcols,pver) + + 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w + + type(interp_type) :: dei_wgts + + integer :: i, k, swband + real(r8) :: ext(nswbands), ssa(nswbands), asm(nswbands) + + do k = 1,pver + do i = 1,ncol + if( iciwpth(i,k) < 1.e-80_r8 .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 + tau_w_g(:,i,k) = 0._r8 + tau_w_f(:,i,k) = 0._r8 + else + ! for each cell interpolate to find weights in g_d_eff grid. + call lininterp_init(g_d_eff, n_g_d, dei(i:i,k), 1, & + extrap_method_bndry, dei_wgts) + ! interpolate into grid and extract radiative properties + do swband = 1, nswbands + call lininterp(ext_sw_ice(:,swband), n_g_d, & + ext(swband:swband), 1, dei_wgts) + call lininterp(ssa_sw_ice(:,swband), n_g_d, & + ssa(swband:swband), 1, dei_wgts) + call lininterp(asm_sw_ice(:,swband), n_g_d, & + asm(swband:swband), 1, dei_wgts) + end do + tau (:,i,k) = iciwpth(i,k) * ext + tau_w (:,i,k) = tau(:,i,k) * ssa + tau_w_g(:,i,k) = tau_w(:,i,k) * asm + tau_w_f(:,i,k) = tau_w_g(:,i,k) * asm + call lininterp_finish(dei_wgts) + endif + enddo + enddo + +end subroutine interpolate_ice_optics_sw + !============================================================================== subroutine interpolate_ice_optics_lw(ncol, iciwpth, dei, abs_od) diff --git a/src/physics/cam/ebert_curry.F90 b/src/physics/cam/ebert_curry.F90 index e218b8e7b3..8a47714c19 100644 --- a/src/physics/cam/ebert_curry.F90 +++ b/src/physics/cam/ebert_curry.F90 @@ -174,6 +174,7 @@ subroutine ec_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice end do ! nswbands end subroutine ec_ice_optics_sw + !============================================================================== subroutine ec_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp) @@ -257,6 +258,7 @@ subroutine ec_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp) enddo end subroutine ec_ice_get_rad_props_lw + !============================================================================== end module ebert_curry diff --git a/src/physics/cam/oldcloud.F90 b/src/physics/cam/oldcloud.F90 index 06a91b232e..d34794e4f1 100644 --- a/src/physics/cam/oldcloud.F90 +++ b/src/physics/cam/oldcloud.F90 @@ -7,18 +7,22 @@ module oldcloud use ppgrid, only: pcols, pver, pverp use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field -use radconstants, only: nswbands, nlwbands, get_sw_spectral_boundaries -use cam_abortutils, only: endrun -use cam_history, only: outfld -use rad_constituents, only: iceopticsfile, liqopticsfile +use constituents, only: cnst_get_ind +use physconst, only: gravit +use radconstants, only: nlwbands use ebert_curry, only: scalefactor +use cam_abortutils, only: endrun + implicit none private save public :: & - oldcloud_init, oldcloud_lw, old_liq_get_rad_props_lw, old_ice_get_rad_props_lw + oldcloud_init, & + oldcloud_lw, & + old_liq_get_rad_props_lw, & + old_ice_get_rad_props_lw integer :: nmu, nlambda real(r8), allocatable :: g_mu(:) ! mu samples on grid @@ -37,29 +41,23 @@ module oldcloud ! Minimum cloud amount (as a fraction of the grid-box area) to ! distinguish from clear sky -! - real(r8) cldmin - parameter (cldmin = 1.0e-80_r8) -! +real(r8), parameter :: cldmin = 1.0e-80_r8 + ! Decimal precision of cloud amount (0 -> preserve full resolution; ! 10^-n -> preserve n digits of cloud amount) -! - real(r8) cldeps - parameter (cldeps = 0.0_r8) - -! -! indexes into pbuf for optical parameters of MG clouds -! - integer :: iciwp_idx = 0 - integer :: iclwp_idx = 0 - integer :: cld_idx = 0 - integer :: rel_idx = 0 - integer :: rei_idx = 0 +real(r8), parameter :: cldeps = 0.0_r8 + +! indexes into pbuf +integer :: iciwp_idx = 0 +integer :: iclwp_idx = 0 +integer :: cld_idx = 0 +integer :: rel_idx = 0 +integer :: rei_idx = 0 ! indexes into constituents for old optics - integer :: & - ixcldice, & ! cloud ice water index - ixcldliq ! cloud liquid water index +integer :: & + ixcldice, & ! cloud ice water index + ixcldliq ! cloud liquid water index !============================================================================== @@ -68,7 +66,6 @@ module oldcloud subroutine oldcloud_init() - use constituents, only: cnst_get_ind integer :: err @@ -86,275 +83,10 @@ subroutine oldcloud_init() end subroutine oldcloud_init -!============================================================================== -! Private methods -!============================================================================== - -subroutine old_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp) - - use physconst, only: gravit - - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - logical, intent(in) :: oldliqwp - - real(r8), pointer, dimension(:,:) :: rel - real(r8), pointer, dimension(:,:) :: cldn - real(r8), pointer, dimension(:,:) :: tmpptr - real(r8), dimension(pcols,pver) :: cliqwp - real(r8), dimension(nswbands) :: wavmin - real(r8), dimension(nswbands) :: wavmax - - ! Minimum cloud amount (as a fraction of the grid-box area) to - ! distinguish from clear sky - real(r8), parameter :: cldmin = 1.0e-80_r8 - - ! Decimal precision of cloud amount (0 -> preserve full resolution; - ! 10^-n -> preserve n digits of cloud amount) - real(r8), parameter :: cldeps = 0.0_r8 - - ! A. Slingo's data for cloud particle radiative properties (from 'A GCM - ! Parameterization for the Shortwave Properties of Water Clouds' JAS - ! vol. 46 may 1989 pp 1419-1427) - real(r8) :: abarl(4) = & ! A coefficient for extinction optical depth - (/ 2.817e-02_r8, 2.682e-02_r8,2.264e-02_r8,1.281e-02_r8/) - real(r8) :: bbarl(4) = & ! B coefficient for extinction optical depth - (/ 1.305_r8 , 1.346_r8 ,1.454_r8 ,1.641_r8 /) - real(r8) :: cbarl(4) = & ! C coefficient for single scat albedo - (/-5.62e-08_r8 ,-6.94e-06_r8 ,4.64e-04_r8 ,0.201_r8 /) - real(r8) :: dbarl(4) = & ! D coefficient for single scat albedo - (/ 1.63e-07_r8 , 2.35e-05_r8 ,1.24e-03_r8 ,7.56e-03_r8 /) - real(r8) :: ebarl(4) = & ! E coefficient for asymmetry parameter - (/ 0.829_r8 , 0.794_r8 ,0.754_r8 ,0.826_r8 /) - real(r8) :: fbarl(4) = & ! F coefficient for asymmetry parameter - (/ 2.482e-03_r8, 4.226e-03_r8,6.560e-03_r8,4.353e-03_r8/) - - real(r8) :: abarli ! A coefficient for current spectral band - real(r8) :: bbarli ! B coefficient for current spectral band - real(r8) :: cbarli ! C coefficient for current spectral band - real(r8) :: dbarli ! D coefficient for current spectral band - real(r8) :: ebarli ! E coefficient for current spectral band - real(r8) :: fbarli ! F coefficient for current spectral band - - ! Caution... A. Slingo recommends no less than 4.0 micro-meters nor - ! greater than 20 micro-meters - - integer :: ns, i, k, indxsl, Nday - integer :: lchnk, itim_old - real(r8) :: tmp1l, tmp2l, tmp3l, g - real(r8) :: kext(pcols,pver) - real(r8), pointer, dimension(:,:) :: iclwpth - - Nday = state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx,cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, rel_idx,rel) - - if (oldliqwp) then - do k=1,pver - do i = 1,Nday - cliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/(gravit*max(0.01_r8,cldn(i,k))) - end do - end do - else - if (iclwp_idx<0) then - call endrun('old_liquid_optics_sw: oldliqwp must be set to true since ICLWP was not found in pbuf') - endif - ! The following is the eventual target specification for in cloud liquid water path. - call pbuf_get_field(pbuf, iclwp_idx, tmpptr) - cliqwp = tmpptr - endif - - call get_sw_spectral_boundaries(wavmin,wavmax,'microns') - - do ns = 1, nswbands - ! Set index for cloud particle properties based on the wavelength, - ! according to A. Slingo (1989) equations 1-3: - ! Use index 1 (0.25 to 0.69 micrometers) for visible - ! Use index 2 (0.69 - 1.19 micrometers) for near-infrared - ! Use index 3 (1.19 to 2.38 micrometers) for near-infrared - ! Use index 4 (2.38 to 4.00 micrometers) for near-infrared - if(wavmax(ns) <= 0.7_r8) then - indxsl = 1 - else if(wavmax(ns) <= 1.25_r8) then - indxsl = 2 - else if(wavmax(ns) <= 2.38_r8) then - indxsl = 3 - else if(wavmin(ns) > 2.38_r8) then - indxsl = 4 - end if - - ! Set cloud extinction optical depth, single scatter albedo, - ! asymmetry parameter, and forward scattered fraction: - abarli = abarl(indxsl) - bbarli = bbarl(indxsl) - cbarli = cbarl(indxsl) - dbarli = dbarl(indxsl) - ebarli = ebarl(indxsl) - fbarli = fbarl(indxsl) - - do k=1,pver - do i=1,Nday - - ! note that optical properties for liquid valid only - ! in range of 4.2 > rel > 16 micron (Slingo 89) - if (cldn(i,k) >= cldmin .and. cldn(i,k) >= cldeps) then - tmp1l = abarli + bbarli/min(max(4.2_r8,rel(i,k)),16._r8) - liq_tau(ns,i,k) = 1000._r8*cliqwp(i,k)*tmp1l - else - liq_tau(ns,i,k) = 0.0_r8 - endif - - tmp2l = 1._r8 - cbarli - dbarli*min(max(4.2_r8,rel(i,k)),16._r8) - tmp3l = fbarli*min(max(4.2_r8,rel(i,k)),16._r8) - ! Do not let single scatter albedo be 1. Delta-eddington solution - ! for non-conservative case has different analytic form from solution - ! for conservative case, and raddedmx is written for non-conservative case. - liq_tau_w(ns,i,k) = liq_tau(ns,i,k) * min(tmp2l,.999999_r8) - g = ebarli + tmp3l - liq_tau_w_g(ns,i,k) = liq_tau_w(ns,i,k) * g - liq_tau_w_f(ns,i,k) = liq_tau_w(ns,i,k) * g * g - - end do ! End do i=1,Nday - end do ! End do k=1,pver - end do ! nswbands - -end subroutine old_liquid_optics_sw -!============================================================================== - -subroutine old_ice_optics_sw (state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp) - - use physconst, only: gravit - - type(physics_state), intent(in) :: state - type(physics_buffer_desc),pointer :: pbuf(:) - - 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_f(nswbands,pcols,pver) ! forward scattered fraction * tau * w - logical, intent(in) :: oldicewp - - real(r8), pointer, dimension(:,:) :: rei - real(r8), pointer, dimension(:,:) :: cldn - real(r8), pointer, dimension(:,:) :: tmpptr - real(r8), dimension(pcols,pver) :: cicewp - real(r8), dimension(nswbands) :: wavmin - real(r8), dimension(nswbands) :: wavmax - ! - ! ice water coefficients (Ebert and Curry,1992, JGR, 97, 3831-3836) - real(r8) :: abari(4) = & ! a coefficient for extinction optical depth - (/ 3.448e-03_r8, 3.448e-03_r8,3.448e-03_r8,3.448e-03_r8/) - real(r8) :: bbari(4) = & ! b coefficient for extinction optical depth - (/ 2.431_r8 , 2.431_r8 ,2.431_r8 ,2.431_r8 /) - real(r8) :: cbari(4) = & ! c coefficient for single scat albedo - (/ 1.00e-05_r8 , 1.10e-04_r8 ,1.861e-02_r8,.46658_r8 /) - real(r8) :: dbari(4) = & ! d coefficient for single scat albedo - (/ 0.0_r8 , 1.405e-05_r8,8.328e-04_r8,2.05e-05_r8 /) - real(r8) :: ebari(4) = & ! e coefficient for asymmetry parameter - (/ 0.7661_r8 , 0.7730_r8 ,0.794_r8 ,0.9595_r8 /) - real(r8) :: fbari(4) = & ! f coefficient for asymmetry parameter - (/ 5.851e-04_r8, 5.665e-04_r8,7.267e-04_r8,1.076e-04_r8/) - - real(r8) :: abarii ! A coefficient for current spectral band - real(r8) :: bbarii ! B coefficient for current spectral band - real(r8) :: cbarii ! C coefficient for current spectral band - real(r8) :: dbarii ! D coefficient for current spectral band - real(r8) :: ebarii ! E coefficient for current spectral band - real(r8) :: fbarii ! F coefficient for current spectral band - - ! Minimum cloud amount (as a fraction of the grid-box area) to - ! distinguish from clear sky - real(r8), parameter :: cldmin = 1.0e-80_r8 - - ! Decimal precision of cloud amount (0 -> preserve full resolution; - ! 10^-n -> preserve n digits of cloud amount) - real(r8), parameter :: cldeps = 0.0_r8 - - integer :: ns, i, k, indxsl, lchnk, Nday - integer :: itim_old - real(r8) :: tmp1i, tmp2i, tmp3i, g - - Nday = state%ncol - lchnk = state%lchnk - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, cld_idx,cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, rei_idx,rei) - - if(oldicewp) then - do k=1,pver - do i = 1,Nday - cicewp(i,k) = 1000.0_r8*state%q(i,k,ixcldice)*state%pdel(i,k) /(gravit* max(0.01_r8,cldn(i,k))) - end do - end do - else - if (iciwp_idx<=0) then - call endrun('old_ice_optics_sw: oldicewp must be set to true since ICIWP was not found in pbuf') - endif - call pbuf_get_field(pbuf, iciwp_idx, tmpptr) - cicewp(1:pcols,1:pver) = 1000.0_r8*tmpptr - endif - - call get_sw_spectral_boundaries(wavmin,wavmax,'microns') - - do ns = 1, nswbands - - if(wavmax(ns) <= 0.7_r8) then - indxsl = 1 - else if(wavmax(ns) <= 1.25_r8) then - indxsl = 2 - else if(wavmax(ns) <= 2.38_r8) then - indxsl = 3 - else if(wavmin(ns) > 2.38_r8) then - indxsl = 4 - end if - - abarii = abari(indxsl) - bbarii = bbari(indxsl) - cbarii = cbari(indxsl) - dbarii = dbari(indxsl) - ebarii = ebari(indxsl) - fbarii = fbari(indxsl) - - do k=1,pver - do i=1,Nday - - ! note that optical properties for ice valid only - ! in range of 13 > rei > 130 micron (Ebert and Curry 92) - if (cldn(i,k) >= cldmin .and. cldn(i,k) >= cldeps) then - tmp1i = abarii + bbarii/max(13._r8,min(scalefactor*rei(i,k),130._r8)) - ice_tau(ns,i,k) = cicewp(i,k)*tmp1i - else - ice_tau(ns,i,k) = 0.0_r8 - endif - - tmp2i = 1._r8 - cbarii - dbarii*min(max(13._r8,scalefactor*rei(i,k)),130._r8) - tmp3i = fbarii*min(max(13._r8,scalefactor*rei(i,k)),130._r8) - ! Do not let single scatter albedo be 1. Delta-eddington solution - ! for non-conservative case has different analytic form from solution - ! for conservative case, and raddedmx is written for non-conservative case. - ice_tau_w(ns,i,k) = ice_tau(ns,i,k) * min(tmp2i,.999999_r8) - g = ebarii + tmp3i - ice_tau_w_g(ns,i,k) = ice_tau_w(ns,i,k) * g - ice_tau_w_f(ns,i,k) = ice_tau_w(ns,i,k) * g * g - - end do ! End do i=1,Nday - end do ! End do k=1,pver - end do ! nswbands - -end subroutine old_ice_optics_sw !============================================================================== subroutine oldcloud_lw(state,pbuf,cld_abs_od,oldwp) - use physconst, only: gravit + type(physics_state), intent(in) :: state type(physics_buffer_desc),pointer :: pbuf(:) real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer @@ -432,8 +164,8 @@ subroutine oldcloud_lw(state,pbuf,cld_abs_od,oldwp) end subroutine oldcloud_lw !============================================================================== + subroutine old_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp) - use physconst, only: gravit type(physics_state), intent(in) :: state type(physics_buffer_desc),pointer :: pbuf(:) @@ -513,10 +245,11 @@ subroutine old_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp) end subroutine old_liq_get_rad_props_lw + !============================================================================== subroutine old_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp) - use physconst, only: gravit + type(physics_state), intent(in) :: state type(physics_buffer_desc),pointer :: pbuf(:) real(r8), intent(out) :: abs_od(nlwbands,pcols,pver) @@ -594,43 +327,7 @@ subroutine old_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp) abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver) enddo - !if(oldicewp) then - ! call outfld('CIWPTH_OLD',cicewp(:,:)/1000,pcols,lchnk) - !else - ! call outfld('CIWPTH_OLD',iciwpth(:,:),pcols,lchnk) - !endif - !call outfld('CI_OD_LW_OLD',cldtau(:,:),pcols,lchnk) - end subroutine old_ice_get_rad_props_lw -!============================================================================== - -subroutine cloud_total_vis_diag_out(lchnk, nnite, idxnite, tau, radsuffix) - - ! output total aerosol optical depth for the visible band - - use cam_history, only: outfld - use cam_history_support, only : fillvalue - - integer, intent(in) :: lchnk - integer, intent(in) :: nnite ! number of night columns - integer, intent(in) :: idxnite(nnite) ! local column indices of night columns - real(r8), intent(in) :: tau(:,:) - character(len=*), intent(in) :: radsuffix ! identifies whether the radiation call - ! is for the climate calc or a diagnostic calc - - ! Local variables - integer :: i - real(r8) :: tmp(pcols) - !----------------------------------------------------------------------------- - - ! compute total aerosol optical depth output where only daylight columns - tmp(:) = sum(tau(:,:), 2) - do i = 1, nnite - tmp(idxnite(i)) = fillvalue - end do - !call outfld('cloudOD_v'//trim(radsuffix), tmp, pcols, lchnk) - -end subroutine cloud_total_vis_diag_out !============================================================================== diff --git a/src/physics/cam/slingo.F90 b/src/physics/cam/slingo.F90 index 98018afa0f..80d42733b2 100644 --- a/src/physics/cam/slingo.F90 +++ b/src/physics/cam/slingo.F90 @@ -24,30 +24,23 @@ module slingo ! Minimum cloud amount (as a fraction of the grid-box area) to ! distinguish from clear sky -! - real(r8) cldmin - parameter (cldmin = 1.0e-80_r8) -! +real(r8), parameter :: cldmin = 1.0e-80_r8 + ! Decimal precision of cloud amount (0 -> preserve full resolution; ! 10^-n -> preserve n digits of cloud amount) -! - real(r8) cldeps - parameter (cldeps = 0.0_r8) +real(r8), parameter :: cldeps = 0.0_r8 -! ! indexes into pbuf for optical parameters of MG clouds -! - integer :: iclwp_idx = 0 - integer :: iciwp_idx = 0 - integer :: cld_idx = 0 - integer :: rel_idx = 0 - integer :: rei_idx = 0 +integer :: iclwp_idx = 0 +integer :: iciwp_idx = 0 +integer :: cld_idx = 0 +integer :: rel_idx = 0 +integer :: rei_idx = 0 ! indexes into constituents for old optics - integer :: & - ixcldliq, & ! cloud liquid water index - ixcldice ! cloud liquid water index - +integer :: & + ixcldliq, & ! cloud liquid water index + ixcldice ! cloud liquid water index !============================================================================== contains @@ -82,7 +75,6 @@ end subroutine slingo_rad_props_init !============================================================================== - subroutine slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp) type(physics_state), intent(in) :: state @@ -101,14 +93,6 @@ subroutine slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, li real(r8), dimension(nswbands) :: wavmin real(r8), dimension(nswbands) :: wavmax - ! Minimum cloud amount (as a fraction of the grid-box area) to - ! distinguish from clear sky - real(r8), parameter :: cldmin = 1.0e-80_r8 - - ! Decimal precision of cloud amount (0 -> preserve full resolution; - ! 10^-n -> preserve n digits of cloud amount) - real(r8), parameter :: cldeps = 0.0_r8 - ! A. Slingo's data for cloud particle radiative properties (from 'A GCM ! Parameterization for the Shortwave Properties of Water Clouds' JAS ! vol. 46 may 1989 pp 1419-1427) @@ -295,7 +279,6 @@ subroutine slingo_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp) abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver) enddo - end subroutine slingo_liq_get_rad_props_lw end module slingo diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index e0d074e904..5d34b6533b 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -867,9 +867,9 @@ subroutine radiation_tend( & use cloud_rad_props, only: get_ice_optics_sw, ice_cloud_get_rad_props_lw, & get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & get_snow_optics_sw, snow_cloud_get_rad_props_lw, & - cloud_rad_props_get_lw, & - grau_cloud_get_rad_props_lw, & - get_grau_optics_sw + get_grau_optics_sw, grau_cloud_get_rad_props_lw, & + cloud_rad_props_get_lw + 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 From 749f90a3c07d95ea5b50b24dd19aaee6d6ee993f Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 20 Sep 2023 12:54:26 -0400 Subject: [PATCH 31/53] refactor setting cloud_sw object --- src/physics/rrtmgp/radiation.F90 | 253 +++++++++++++-------------- src/physics/rrtmgp/rrtmgp_inputs.F90 | 196 ++++++++++++--------- 2 files changed, 226 insertions(+), 223 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 5d34b6533b..40b8ca444b 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -189,7 +189,8 @@ module radiation integer :: cld_idx = 0 integer :: cldfgrau_idx = 0 -character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) +character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ',& + '_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) ! averaging time interval for zenith angle real(r8) :: dt_avg = 0._r8 @@ -206,10 +207,11 @@ module radiation ! extra layer that is added between 1 Pa and the model top. ! 2. If the WACCM model top is above 1 Pa, then RRMTGP only does calculations ! for those model layers that are below 1 Pa. -integer :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which RRTMGP is active. -integer :: ktoprad ! Index in RRTMGP arrays of the layer or interface corresponding to CAM's top - ! layer or interface. - ! For CAM's top to bottom indexing, the index of a given layer +integer :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which + ! RRTMGP is active. +integer :: ktoprad ! Index in RRTMGP arrays of the layer or interface corresponding + ! to CAM's top layer or interface. + ! Note: for CAM's top to bottom indexing, the index of a given layer ! (midpoint) and the upper interface of that layer, are the same. ! vertical coordinate for output of fluxes on radiation grid @@ -249,11 +251,10 @@ subroutine radiation_readnl(nlfile) ! Local variables integer :: unitn, ierr integer :: dtime ! timestep size - character(len=*), parameter :: subroutine_name = 'radiation_readnl' + character(len=*), parameter :: sub = 'radiation_readnl' character(len=cl) :: rrtmgp_coefs_lw_file, rrtmgp_coefs_sw_file - namelist /radiation_nl/ & rrtmgp_coefs_lw_file, rrtmgp_coefs_sw_file, iradsw, iradlw, & irad_always, use_rad_dt_cosz, spectralflux, use_rad_uniform_angle, & @@ -266,7 +267,7 @@ subroutine radiation_readnl(nlfile) if (ierr == 0) then read(unitn, radiation_nl, iostat=ierr) if (ierr /= 0) then - call endrun(subroutine_name // ':: ERROR reading namelist') + call endrun(sub//': ERROR reading namelist') end if end if close(unitn) @@ -274,28 +275,29 @@ subroutine radiation_readnl(nlfile) ! Broadcast namelist variables call mpi_bcast(rrtmgp_coefs_lw_file, cl, mpi_character, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: rrtmgp_coefs_lw_file") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: rrtmgp_coefs_lw_file") call mpi_bcast(rrtmgp_coefs_sw_file, cl, mpi_character, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: rrtmgp_coefs_sw_file") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: rrtmgp_coefs_sw_file") call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: iradsw") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradsw") call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: iradlw") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradlw") call mpi_bcast(irad_always, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: irad_always") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: irad_always") call mpi_bcast(use_rad_dt_cosz, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: use_rad_dt_cosz") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_rad_dt_cosz") call mpi_bcast(spectralflux, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: spectralflux") + 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(subroutine_name//": FATAL: mpi_bcast: use_rad_uniform_angle") + 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) - if (ierr /= 0) call endrun(subroutine_name//": FATAL: mpi_bcast: rad_uniform_angle") + 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(subroutine_name//": FATAL: mpi_bcast: graupel_in_rad") + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: graupel_in_rad") if (use_rad_uniform_angle .and. rad_uniform_angle == -99._r8) then - call endrun(subroutine_name // ' ERROR - use_rad_uniform_angle is set to .true, but rad_uniform_angle is not set ') + call endrun(sub//': ERROR - use_rad_uniform_angle is set to .true,' & + //' but rad_uniform_angle is not set ') end if ! Set module data @@ -348,7 +350,7 @@ subroutine radiation_register call pbuf_add_field('FLNT' , 'global',dtype_r8,(/pcols/), flnt_idx) ! Top-of-model net longwave flux ! If the namelist has been configured for preserving the spectral fluxes, then create - ! physics buffer variables to store the results. + ! physics buffer variables to store the results. This data is accessed by CARMA. if (spectralflux) then call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) @@ -599,66 +601,72 @@ subroutine radiation_init(pbuf2d) if (active_calls(icall)) then - call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar insolation', sampling_seq='rad_lwsw') - - call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Solar heating rate', sampling_seq='rad_lwsw') - call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky solar heating rate', & - sampling_seq='rad_lwsw') - call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Shortwave cloud forcing', & - sampling_seq='rad_lwsw') - call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') - call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & + call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Solar insolation', sampling_seq='rad_lwsw') + call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', & + 'Solar heating rate', sampling_seq='rad_lwsw') + call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', & + 'Clearsky solar heating rate', sampling_seq='rad_lwsw') + call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net solar flux at top of model', sampling_seq='rad_lwsw') + call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net solar flux at top of model', sampling_seq='rad_lwsw') + call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net solar flux at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net solar flux at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Shortwave cloud forcing', sampling_seq='rad_lwsw') + call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Upwelling solar flux at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & 'Clearsky net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') - call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') - - call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net shortwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net shortwave flux at 200 mb', & - sampling_seq='rad_lwsw') - - call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at tropopause', & - sampling_seq='rad_lwsw') - - call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared direct to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible direct to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared diffuse to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible diffuse to surface', & - sampling_seq='rad_lwsw') - call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at surface', & - sampling_seq='rad_lwsw') - - call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling solar flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky downwelling solar flux at surface', & - sampling_seq='rad_lwsw') - - call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave upward flux') - call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') - call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') - call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') + call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net shortwave flux at 200 mb', sampling_seq='rad_lwsw') + call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net shortwave flux at 200 mb', sampling_seq='rad_lwsw') + call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net solar flux at tropopause', sampling_seq='rad_lwsw') + call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Solar downward near infrared direct to surface', sampling_seq='rad_lwsw') + call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Solar downward visible direct to surface', sampling_seq='rad_lwsw') + call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Solar downward near infrared diffuse to surface', sampling_seq='rad_lwsw') + call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Solar downward visible diffuse to surface', sampling_seq='rad_lwsw') + call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net solar flux at surface', sampling_seq='rad_lwsw') + call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net solar flux at surface', sampling_seq='rad_lwsw') + call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Downwelling solar flux at surface', sampling_seq='rad_lwsw') + call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky downwelling solar flux at surface', sampling_seq='rad_lwsw') + + ! Fluxes on CAM grid + call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', & + 'Shortwave upward flux', sampling_seq='rad_lwsw') + call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', & + 'Shortwave downward flux', sampling_seq='rad_lwsw') + call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', & + 'Shortwave clear-sky upward flux', sampling_seq='rad_lwsw') + call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', & + 'Shortwave clear-sky downward flux', sampling_seq='rad_lwsw') ! Fluxes on RRTMGP grid - call addfld('FSDN'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW downward flux on rrtmgp grid') - call addfld('FSDNC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW downward clear sky flux on rrtmgp grid') - call addfld('FSUP'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW upward flux on rrtmgp grid') - call addfld('FSUPC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'SW upward clear sky flux on rrtmgp grid') + call addfld('FSDN'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & + 'SW downward flux on rrtmgp grid', sampling_seq='rad_lwsw') + call addfld('FSDNC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & + 'SW downward clear sky flux on rrtmgp grid', sampling_seq='rad_lwsw') + call addfld('FSUP'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & + 'SW upward flux on rrtmgp grid', sampling_seq='rad_lwsw') + call addfld('FSUPC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & + 'SW upward clear sky flux on rrtmgp grid', sampling_seq='rad_lwsw') if (history_amwg) then call add_default('SOLIN'//diag(icall), 1, ' ') @@ -718,16 +726,26 @@ subroutine radiation_init(pbuf2d) 'Downwelling longwave flux at surface', sampling_seq='rad_lwsw') call addfld('FLDSC'//diag(icall), horiz_only, 'A', 'W/m2', & 'Clearsky Downwelling longwave flux at surface', sampling_seq='rad_lwsw') - call addfld('FUL'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Longwave upward flux') - call addfld('FDL'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Longwave downward flux') - call addfld('FULC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Longwave clear-sky upward flux') - call addfld('FDLC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Longwave clear-sky downward flux') + + ! Fluxes on CAM grid + call addfld('FUL'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', & + 'Longwave upward flux', sampling_seq='rad_lwsw') + call addfld('FDL'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', & + 'Longwave downward flux', sampling_seq='rad_lwsw') + call addfld('FULC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', & + 'Longwave clear-sky upward flux', sampling_seq='rad_lwsw') + call addfld('FDLC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', & + 'Longwave clear-sky downward flux', sampling_seq='rad_lwsw') ! Fluxes on rrtmgp grid - call addfld('FLDN'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'LW downward flux on rrtmgp grid') - call addfld('FLDNC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'LW downward clear sky flux on rrtmgp grid') - call addfld('FLUP'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'LW upward flux on rrtmgp grid') - call addfld('FLUPC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', 'LW upward clear sky flux on rrtmgp grid') + call addfld('FLDN'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & + 'LW downward flux on rrtmgp grid', sampling_seq='rad_lwsw') + call addfld('FLDNC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & + 'LW downward clear sky flux on rrtmgp grid', sampling_seq='rad_lwsw') + call addfld('FLUP'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & + 'LW upward flux on rrtmgp grid', sampling_seq='rad_lwsw') + call addfld('FLUPC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & + 'LW upward clear sky flux on rrtmgp grid', sampling_seq='rad_lwsw') if (history_amwg) then call add_default('QRL'//diag(icall), 1, ' ') @@ -956,33 +974,32 @@ subroutine radiation_tend( & real(r8), allocatable :: alb_dir(:,:) real(r8), allocatable :: alb_dif(:,:) + ! Forward scattered fraction * tau * w. RRTMGP does not use this property + ! in its 2-stream calculations. No need for separate storage for different cloud types. + real(r8) :: sw_tau_w_f(nswbands,pcols,pver) ! 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_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_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_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) ! "snow" 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_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) ! Add graupel as another snow species. @@ -990,7 +1007,6 @@ subroutine radiation_tend( & 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_f(nswbands,pcols,pver) ! graupel forward scattered fraction * tau * w real(r8) :: grau_lw_abs (nlwbands,pcols,pver)! graupel absorption optics depth (LW) ! combined cloud radiative parameters are "in cloud" not "in cell" @@ -998,7 +1014,6 @@ subroutine radiation_tend( & 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_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) ! Aerosol radiative properties **N.B.** These are zero-indexed to accomodate an "extra layer". @@ -1214,23 +1229,23 @@ subroutine radiation_tend( & if (dosw) then if (oldcldoptics) then - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, sw_tau_w_f, oldicewp=.false.) + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, sw_tau_w_f, oldliqwp=.false.) else select case (icecldoptics) case ('ebertcurry') - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.true.) + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, sw_tau_w_f, oldicewp=.true.) case ('mitchell') - call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) + call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, sw_tau_w_f) case default call endrun('icecldoptics must be one either ebertcurry or mitchell') end select select case (liqcldoptics) case ('slingo') - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, sw_tau_w_f, oldliqwp=.true.) case ('gammadist') - call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) + call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, sw_tau_w_f) case default call endrun('liqcldoptics must be either slingo or gammadist') end select @@ -1239,11 +1254,10 @@ subroutine radiation_tend( & cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) - cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) if (cldfsnow_idx > 0) then ! add in snow - call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, snow_tau_w_f) + call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, sw_tau_w_f) do i = 1, ncol do k = 1, pver if (cldfprime(i,k) > 0.) then @@ -1256,13 +1270,10 @@ subroutine radiation_tend( & c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) - c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & - + cld(i,k)*cld_tau_w_f(:,i,k) )/cldfprime(i,k) else c_cld_tau(:,i,k) = 0._r8 c_cld_tau_w(:,i,k) = 0._r8 c_cld_tau_w_g(:,i,k) = 0._r8 - c_cld_tau_w_f(:,i,k) = 0._r8 end if end do end do @@ -1270,12 +1281,11 @@ subroutine radiation_tend( & c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) - c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) end if if (cldfgrau_idx > 0 .and. graupel_in_rad) then ! add in graupel - call get_grau_optics_sw(state, pbuf, grau_tau, grau_tau_w, grau_tau_w_g, grau_tau_w_f) + call get_grau_optics_sw(state, pbuf, grau_tau, grau_tau_w, grau_tau_w_g, sw_tau_w_f) do i = 1, ncol do k = 1, pver @@ -1289,14 +1299,10 @@ subroutine radiation_tend( & c_cld_tau_w_g(:,i,k) = ( cldfgrau(i,k)*grau_tau_w_g(:,i,k) & + cld(i,k)*c_cld_tau_w_g(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_f(:,i,k) = ( cldfgrau(i,k)*grau_tau_w_f(:,i,k) & - + cld(i,k)*c_cld_tau_w_f(:,i,k) )/cldfprime(i,k) else c_cld_tau(:,i,k) = 0._r8 c_cld_tau_w(:,i,k) = 0._r8 c_cld_tau_w_g(:,i,k) = 0._r8 - c_cld_tau_w_f(:,i,k) = 0._r8 end if end do end do @@ -1309,7 +1315,6 @@ subroutine radiation_tend( & c_cld_tau(:,:ncol,:) = c_cld_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) c_cld_tau_w(:,:ncol,:) = c_cld_tau_w(rrtmg_to_rrtmgp_swbands,:ncol,:) c_cld_tau_w_g(:,:ncol,:) = c_cld_tau_w_g(rrtmg_to_rrtmgp_swbands,:ncol,:) - c_cld_tau_w_f(:,:ncol,:) = c_cld_tau_w_f(rrtmg_to_rrtmgp_swbands,:ncol,:) if (cldfsnow_idx > 0) then snow_tau(:,:ncol,:) = snow_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) end if @@ -1317,13 +1322,10 @@ subroutine radiation_tend( & grau_tau(:,:ncol,:) = grau_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) end if - ! cloud_sw : cloud optical properties. - call initialize_rrtmgp_cloud_optics_sw(nday, nlay, kdist_sw, cloud_sw) - + ! Set cloud optical properties in cloud_sw object. call rrtmgp_set_cloud_sw( & - nswbands, nday, nlay, idxday, pmid_day, & - cldfprime, c_cld_tau, c_cld_tau_w, c_cld_tau_w_g, c_cld_tau_w_f, & - kdist_sw, cloud_sw) + nday, nlay, idxday, pmid_day, cldfprime, & + c_cld_tau, c_cld_tau_w, c_cld_tau_w_g, kdist_sw, cloud_sw) ! SW cloud diagnostics & output @@ -2735,27 +2737,6 @@ end subroutine reset_fluxes !========================================================================================= -subroutine initialize_rrtmgp_cloud_optics_sw(ncol, nlevels, kdist, optics) - - integer, intent(in) :: ncol, nlevels - type(ty_gas_optics_rrtmgp), intent(in) :: kdist - type(ty_optical_props_2str), intent(out) :: optics - - character(len=128) :: errmsg - character(len=128) :: sub = 'initialize_rrtmgp_cloud_optics_sw' - - errmsg = optics%alloc_2str(ncol, nlevels, kdist) - if (len_trim(errmsg) > 0) then - call endrun(trim(sub)//': ERROR: optics%alloc_2str: '//trim(errmsg)) - end if - ! these are all expected to be shape (ncol, nlay, ngpt) - optics%tau = 0.0_r8 - optics%ssa = 1.0_r8 - optics%g = 0.0_r8 -end subroutine initialize_rrtmgp_cloud_optics_sw - -!========================================================================================= - subroutine initialize_rrtmgp_cloud_optics_lw(ncol, nlevels, kdist, optics) integer, intent(in) :: ncol, nlevels diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index f1dbb659e2..1fc3e30094 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -47,15 +47,6 @@ module rrtmgp_inputs real(r8), parameter :: cldmin = 1.0e-80_r8 ! min cloud fraction -real(r8), parameter :: amdw = 1.607793_r8 ! Molecular weight of dry air / water vapor -real(r8), parameter :: amdc = 0.658114_r8 ! Molecular weight of dry air / carbon dioxide -real(r8), parameter :: amdo = 0.603428_r8 ! Molecular weight of dry air / ozone -real(r8), parameter :: amdm = 1.805423_r8 ! Molecular weight of dry air / methane -real(r8), parameter :: amdn = 0.658090_r8 ! Molecular weight of dry air / nitrous oxide -real(r8), parameter :: amdo2 = 0.905140_r8 ! Molecular weight of dry air / oxygen -real(r8), parameter :: amdc1 = 0.210852_r8 ! Molecular weight of dry air / CFC11 -real(r8), parameter :: amdc2 = 0.239546_r8 ! Molecular weight of dry air / CFC12 - ! Indices for copying data between cam and rrtmgp arrays integer :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which ! RRTMGP is active. @@ -247,30 +238,46 @@ end function is_visible !========================================================================================= function get_molar_mass_ratio(gas_name) result(massratio) + ! return the molar mass ratio of dry air to gas based on gas_name + character(len=*),intent(in) :: gas_name real(r8) :: massratio + ! local variables + real(r8), parameter :: amdw = 1.607793_r8 ! Molecular weight of dry air / water vapor + real(r8), parameter :: amdc = 0.658114_r8 ! Molecular weight of dry air / carbon dioxide + real(r8), parameter :: amdo = 0.603428_r8 ! Molecular weight of dry air / ozone + real(r8), parameter :: amdm = 1.805423_r8 ! Molecular weight of dry air / methane + real(r8), parameter :: amdn = 0.658090_r8 ! Molecular weight of dry air / nitrous oxide + real(r8), parameter :: amdo2 = 0.905140_r8 ! Molecular weight of dry air / oxygen + real(r8), parameter :: amdc1 = 0.210852_r8 ! Molecular weight of dry air / CFC11 + real(r8), parameter :: amdc2 = 0.239546_r8 ! Molecular weight of dry air / CFC12 + + character(len=*), parameter :: sub='get_molar_mass_ratio' + !---------------------------------------------------------------------------- + select case (trim(gas_name)) case ('H2O') - massratio = 1.607793_r8 + massratio = amdw case ('CO2') - massratio = 0.658114_r8 + massratio = amdc case ('O3') - massratio = 0.603428_r8 + massratio = amdo case ('CH4') - massratio = 1.805423_r8 + massratio = amdm case ('N2O') - massratio = 0.658090_r8 + massratio = amdn case ('O2') - massratio = 0.905140_r8 + massratio = amdo2 case ('CFC11') - massratio = 0.210852_r8 + massratio = amdc1 case ('CFC12') - massratio = 0.239546_r8 + massratio = amdc2 case default - call endrun("Invalid gas: "//trim(gas_name)) + call endrun(sub//": Invalid gas: "//trim(gas_name)) end select + end function get_molar_mass_ratio !========================================================================================= @@ -496,61 +503,40 @@ end subroutine rrtmgp_set_cloud_lw !================================================================================================== -subroutine rrtmgp_set_aer_lw(ncol, nlwbands, aer_lw_abs, aer_lw) - - ! Load aerosol optical properties into the RRTMGP object. - - ! arguments - integer, intent(in) :: ncol - integer, intent(in) :: nlwbands - real(r8), intent(in) :: aer_lw_abs(pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) - type(ty_optical_props_1scl), intent(inout) :: aer_lw - character(len=32) :: sub = 'rrtmgp_set_aer_lw' - character(len=128) :: errmsg - - !-------------------------------------------------------------------------------- - ! If there is an extra layer in the radiation then this initialization - ! will provide zero optical depths there. - aer_lw%tau = 0.0_r8 - aer_lw%tau(:ncol, ktoprad:, :) = aer_lw_abs(:ncol, ktopcam:, :) - errmsg = aer_lw%validate() - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: aer_lw%validate: '//trim(errmsg)) - end if -end subroutine rrtmgp_set_aer_lw - -!================================================================================================== - subroutine rrtmgp_set_cloud_sw( & - nswbands, nday, nlay, idxday, pmid, cldfrac, & - c_cld_tau, c_cld_tau_w, c_cld_tau_w_g, c_cld_tau_w_f, kdist_sw, & - cloud_sw) + nday, nlay, idxday, pmid, cldfrac, & + c_cld_tau, c_cld_tau_w, c_cld_tau_w_g, kdist_sw, cloud_sw) ! Create MCICA stochastic arrays for cloud SW optical properties. + ! Initialize optical properties object (cloud_sw) and load with MCICA columns. + ! + ! The input optical properties are on the CAM grid and are represented as products + ! of the extinction optical depth (tau), single scattering albedo (w) and assymetry + ! parameter (g). This routine subsets the input to just the layers and the + ! daylight columns used in the radiation calculation. It also computes the + ! individual properties of tau, w, and g for input to the MCICA routine. ! arguments - integer, intent(in) :: nswbands - integer, intent(in) :: nday - integer, intent(in) :: nlay ! number of layers in rad calc (may include "extra layer") - integer, intent(in) :: idxday(:) + integer, intent(in) :: nday ! number of daylight columns + integer, intent(in) :: nlay ! number of layers in radiation calculation (may include "extra layer") + integer, intent(in) :: idxday(:) ! indices of daylight columns in the chunk + real(r8), intent(in) :: pmid(nday,nlay)! pressure at layer midpoints (Pa) used to seed RNG. - real(r8), intent(in) :: pmid(nday,nlay) ! pressure at layer midpoints (Pa) - real(r8), intent(in) :: cldfrac(pcols,pver) ! combined cloud fraction (snow plus regular) - real(r8), intent(in) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth - real(r8), intent(in) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau - real(r8), intent(in) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau - real(r8), intent(in) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau + ! cloud fraction and optics are input on the CAM grid + real(r8), intent(in) :: cldfrac(pcols,pver) ! combined cloud fraction + real(r8), intent(in) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth + real(r8), intent(in) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau + real(r8), intent(in) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau - class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! shortwave gas optics object - type(ty_optical_props_2str), intent(inout) :: cloud_sw ! cloud optical properties object + class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! shortwave gas optics object + type(ty_optical_props_2str), intent(out) :: cloud_sw ! cloud optical properties object ! local vars integer, parameter :: changeseed = 1 integer :: i, k, kk, ns, igpt integer :: ngptsw - integer :: nver ! nver is the number of cam layers in the SW calc. It - ! does not include the "extra layer". + integer :: nver real(r8), allocatable :: cldf(:,:) real(r8), allocatable :: tauc(:,:,:) @@ -560,20 +546,21 @@ subroutine rrtmgp_set_cloud_sw( & real(r8), allocatable :: ssacmcl(:,:,:) real(r8), allocatable :: asmcmcl(:,:,:) - character(len=*), parameter :: sub = 'rrtmgp_set_cloud_sw' - character(len=128) :: errmsg real(r8) :: small_val = 1.e-80_r8 real(r8), allocatable :: day_cld_tau(:,:,:) real(r8), allocatable :: day_cld_tau_w(:,:,:) real(r8), allocatable :: day_cld_tau_w_g(:,:,:) + + character(len=128) :: errmsg + character(len=*), parameter :: sub = 'rrtmgp_set_cloud_sw' !-------------------------------------------------------------------------------- + + ! number of g-points. This is the number of subcolumns constructed by MCICA. ngptsw = kdist_sw%get_ngpt() - nver = pver - ktopcam + 1 ! number of CAM's layers in radiation calculation. - ! Compute the input quantities needed for the 2-stream optical props - ! object. Also subset the vertical levels and the daylight columns - ! here. But don't reorder the vertical index because the mcica sub-column - ! generator assumes the CAM vertical indexing. + ! number of CAM's layers in radiation calculation. Does not include the "extra layer". + nver = pver - ktopcam + 1 + allocate( & cldf(nday,nver), & tauc(nswbands,nday,nver), & @@ -586,53 +573,63 @@ subroutine rrtmgp_set_cloud_sw( & day_cld_tau_w(nswbands,nday,nver), & day_cld_tau_w_g(nswbands,nday,nver)) - ! get daylit arrays on radiation levels, note: expect idxday to be truncated to size nday + ! Subset the input data so just the daylight columns, and the number of CAM layers in the + ! radiation calculation are used by MCICA to produce subcolumns. + cldf = cldfrac( idxday(1:nday), ktopcam:) day_cld_tau = c_cld_tau( :, idxday(1:nday), ktopcam:) day_cld_tau_w = c_cld_tau_w( :, idxday(1:nday), ktopcam:) day_cld_tau_w_g = c_cld_tau_w_g(:, idxday(1:nday), ktopcam:) - cldf = cldfrac(idxday(1:nday), ktopcam:) ! daylit cloud fraction on radiation levels - tauc = merge(day_cld_tau, 0.0_r8, day_cld_tau > 0.0_r8) ! start by setting cloud optical depth, clip @ zero - asmc = merge(day_cld_tau_w_g / max(day_cld_tau_w, small_val), 0.0_r8, day_cld_tau_w > 0.0_r8) ! set value of asymmetry - ssac = merge(max(day_cld_tau_w, small_val) / max(tauc, small_val), 1.0_r8 , tauc > 0.0_r8) - asmc = merge(asmc, 0.0_r8, tauc > 0.0_r8) ! double-check asymmetry; reset when tauc = 0 + ! Compute the optical properties needed for the 2-stream calculations. These calculations + ! are the same as the RRTMG version. - ! mcica_subcol_sw converts to gpts (e.g., 224 pts instead of 14 bands) - ! inputs (pmid, cldf, tauc, ssac, asmc) and outputs (taucmcl, ssacmcl, asmcmcl) - ! are on the same nver vertical levels - ! output is shape (ngpt, ncol, nver) + ! set cloud optical depth, clip @ zero + tauc = merge(day_cld_tau, 0.0_r8, day_cld_tau > 0.0_r8) + ! set value of asymmetry + asmc = merge(day_cld_tau_w_g / max(day_cld_tau_w, small_val), 0.0_r8, day_cld_tau_w > 0.0_r8) + ! set value of single scattering albedo + ssac = merge(max(day_cld_tau_w, small_val) / max(tauc, small_val), 1.0_r8 , tauc > 0.0_r8) + ! set asymmetry to zero when tauc = 0 + asmc = merge(asmc, 0.0_r8, tauc > 0.0_r8) + + ! MCICA converts from bands to gpts (e.g., 224 g-points instead of 14 bands) call mcica_subcol_sw( & - kdist_sw, nswbands, ngptsw, nday, nlay, nver, changeseed, & - pmid, cldf, tauc, ssac, asmc, & - taucmcl, ssacmcl, asmcmcl) ! 32 + kdist_sw, nswbands, ngptsw, nday, nlay, & + nver, changeseed, pmid, cldf, tauc, & + ssac, asmc, taucmcl, ssacmcl, asmcmcl) + ! Initialize object for SW cloud optical properties. + errmsg = cloud_sw%alloc_2str(nday, nlay, kdist_sw) + if (len_trim(errmsg) > 0) then + call endrun(trim(sub)//': ERROR: cloud_sw%alloc_2str: '//trim(errmsg)) + end if ! If there is an extra layer in the radiation then this initialization ! will provide the optical properties there. - ! These are shape (ncol, nlay, ngpt) - cloud_sw%tau(:,:,:) = 0.0_r8 - cloud_sw%ssa(:,:,:) = 1.0_r8 - cloud_sw%g(:,:,:) = 0.0_r8 + cloud_sw%tau = 0.0_r8 + cloud_sw%ssa = 1.0_r8 + cloud_sw%g = 0.0_r8 + + ! Set the properties on g-points. do igpt = 1,ngptsw cloud_sw%g (:, ktoprad:, igpt) = asmcmcl(igpt, ktopcam:, :) cloud_sw%ssa(:, ktoprad:, igpt) = ssacmcl(igpt, ktopcam:, :) cloud_sw%tau(:, ktoprad:, igpt) = taucmcl(igpt, ktopcam:, :) end do - + ! validate checks the tau > 0, ssa is in range [0,1], and g is in range [-1,1]. errmsg = cloud_sw%validate() if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: cloud_sw%validate: '//trim(errmsg)) end if ! delta scaling adjusts for forward scattering - ! If delta_scale() is applied, cloud_sw%tau differs from RRTMG implementation going into SW calculation. errmsg = cloud_sw%delta_scale() if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: cloud_sw%delta_scale: '//trim(errmsg)) end if - ! all information is in cloud_sw, now deallocate + ! All information is in cloud_sw, now deallocate local vars. deallocate( & cldf, tauc, ssac, asmc, & taucmcl, ssacmcl, asmcmcl,& @@ -642,6 +639,31 @@ end subroutine rrtmgp_set_cloud_sw !================================================================================================== +subroutine rrtmgp_set_aer_lw(ncol, nlwbands, aer_lw_abs, aer_lw) + + ! Load aerosol optical properties into the RRTMGP object. + + ! arguments + integer, intent(in) :: ncol + integer, intent(in) :: nlwbands + real(r8), intent(in) :: aer_lw_abs(pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + type(ty_optical_props_1scl), intent(inout) :: aer_lw + character(len=32) :: sub = 'rrtmgp_set_aer_lw' + character(len=128) :: errmsg + + !-------------------------------------------------------------------------------- + ! If there is an extra layer in the radiation then this initialization + ! will provide zero optical depths there. + aer_lw%tau = 0.0_r8 + aer_lw%tau(:ncol, ktoprad:, :) = aer_lw_abs(:ncol, ktopcam:, :) + errmsg = aer_lw%validate() + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: aer_lw%validate: '//trim(errmsg)) + end if +end subroutine rrtmgp_set_aer_lw + +!================================================================================================== + subroutine rrtmgp_set_aer_sw( & nday, idxday, aer_tau, aer_tau_w, & aer_tau_w_g, aer_tau_w_f, aer_sw) From 4d069dc67f086f08da08482502c75481432212ca Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 22 Sep 2023 10:46:44 -0400 Subject: [PATCH 32/53] remove old cloud optics; refactor setting cloud_sw & aer_sw objects --- src/physics/rrtmgp/radiation.F90 | 260 +++------------------ src/physics/rrtmgp/rrtmgp_inputs.F90 | 331 ++++++++++++++++++++------- 2 files changed, 280 insertions(+), 311 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 40b8ca444b..bd8ec09e05 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -22,13 +22,13 @@ module radiation get_curr_calday, get_step_size use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, & - rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & - liqcldoptics, icecldoptics + rad_cnst_get_gas, rad_cnst_out + use rrtmgp_inputs, only: rrtmgp_inputs_init -use radconstants, only: nswbands, nlwbands, nswgpts, nlwgpts, idx_sw_diag, & - idx_nir_diag, idx_uv_diag, idx_lw_diag, idx_sw_cloudsim, & +use radconstants, only: nswbands, nlwbands, nswgpts, & + idx_nir_diag, idx_uv_diag, idx_lw_diag, & idx_lw_cloudsim, nradgas, gasnamelength, gaslist, & set_wavenumber_bands @@ -40,7 +40,7 @@ module radiation use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active -use cam_history_support, only: fillvalue, add_vert_coord +use cam_history_support, only: add_vert_coord use radiation_data, only: rad_data_register, rad_data_init @@ -237,7 +237,6 @@ module radiation contains !========================================================================================= - subroutine radiation_readnl(nlfile) ! Read radiation_nl namelist group. @@ -880,18 +879,13 @@ subroutine radiation_tend( & rrtmgp_set_aer_lw, rrtmgp_set_gases_sw, rrtmgp_set_cloud_sw, & rrtmgp_set_aer_sw - use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw + use aer_rad_props, only: aer_rad_props_lw - use cloud_rad_props, only: get_ice_optics_sw, ice_cloud_get_rad_props_lw, & - get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & - get_snow_optics_sw, snow_cloud_get_rad_props_lw, & - get_grau_optics_sw, grau_cloud_get_rad_props_lw, & - cloud_rad_props_get_lw + use cloud_rad_props, only: ice_cloud_get_rad_props_lw, & + liquid_cloud_get_rad_props_lw, & + snow_cloud_get_rad_props_lw, & + grau_cloud_get_rad_props_lw - - 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 - ! RRTMGP drivers for flux calculations. use rrtmgp_driver, only: rte_lw use mo_rte_sw, only: rte_sw @@ -924,6 +918,7 @@ subroutine radiation_tend( & integer :: i, k integer :: lchnk, ncol logical :: dosw, dolw + integer :: icall ! loop index for climate/diagnostic radiation calls real(r8) :: calday ! current calendar day real(r8) :: delta ! Solar declination angle in radians @@ -944,6 +939,7 @@ subroutine radiation_tend( & real(r8), pointer :: cld(:,:) ! cloud fraction real(r8), pointer :: cldfsnow(:,:) => null() ! cloud fraction of just "snow clouds" real(r8), pointer :: cldfgrau(:,:) => null() ! cloud fraction of just "graupel clouds" + real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction real(r8), pointer :: qrs(:,:) => null() ! shortwave radiative heating rate real(r8), pointer :: qrl(:,:) => null() ! longwave radiative heating rate real(r8), pointer :: fsds(:) ! Surface solar down flux @@ -974,54 +970,19 @@ subroutine radiation_tend( & real(r8), allocatable :: alb_dir(:,:) real(r8), allocatable :: alb_dif(:,:) - ! Forward scattered fraction * tau * w. RRTMGP does not use this property - ! in its 2-stream calculations. No need for separate storage for different cloud types. - real(r8) :: sw_tau_w_f(nswbands,pcols,pver) + real(r8) :: cld_tau_cloudsim(pcols,pver) ! in-cloud liq+ice optical depth (for COSP) + real(r8) :: snow_tau_cloudsim(pcols,pver)! in-cloud snow optical depth (for COSP) + real(r8) :: grau_tau_cloudsim(pcols,pver)! in-cloud Graupel optical depth (for COSP) - ! 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_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_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_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) - - ! "snow" 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_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) - - ! Add graupel as another snow species. - ! 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_lw_abs (nlwbands,pcols,pver)! graupel absorption optics depth (LW) - - ! combined cloud radiative parameters are "in cloud" not "in cell" - 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_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) ! Aerosol radiative properties **N.B.** These are zero-indexed to accomodate an "extra layer". ! If no extra layer then the 0 index is ignored. - 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_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) ! Set vertical indexing in RRTMGP to be the same as CAM (top to bottom). @@ -1031,8 +992,6 @@ subroutine radiation_tend( & type(ty_optical_props_1scl) :: cloud_lw type(ty_optical_props_2str) :: cloud_sw - integer :: icall ! index through climate/diagnostic radiation calls - ! gas vmr. Separate objects because SW only does calculations for daylight columns. type(ty_gas_concs) :: gas_concs_lw type(ty_gas_concs) :: gas_concs_sw @@ -1228,134 +1187,14 @@ subroutine radiation_tend( & if (dosw) then - if (oldcldoptics) then - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, sw_tau_w_f, oldicewp=.false.) - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, sw_tau_w_f, oldliqwp=.false.) - else - select case (icecldoptics) - case ('ebertcurry') - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, sw_tau_w_f, oldicewp=.true.) - case ('mitchell') - call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, sw_tau_w_f) - case default - call endrun('icecldoptics must be one either ebertcurry or mitchell') - end select - - select case (liqcldoptics) - case ('slingo') - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, sw_tau_w_f, oldliqwp=.true.) - case ('gammadist') - call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, sw_tau_w_f) - case default - call endrun('liqcldoptics must be either slingo or gammadist') - end select - end if - - cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) - cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) - cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) - - if (cldfsnow_idx > 0) then - ! add in snow - call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, sw_tau_w_f) - do i = 1, ncol - do k = 1, pver - if (cldfprime(i,k) > 0.) then - c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & - + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & - + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & - + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) - - else - c_cld_tau(:,i,k) = 0._r8 - c_cld_tau_w(:,i,k) = 0._r8 - c_cld_tau_w_g(:,i,k) = 0._r8 - end if - end do - end do - else - c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) - c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) - c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) - end if - - if (cldfgrau_idx > 0 .and. graupel_in_rad) then - ! add in graupel - call get_grau_optics_sw(state, pbuf, grau_tau, grau_tau_w, grau_tau_w_g, sw_tau_w_f) - do i = 1, ncol - do k = 1, pver - - if (cldfprime(i,k) > 0._r8) then - - c_cld_tau(:,i,k) = ( cldfgrau(i,k)*grau_tau(:,i,k) & - + cld(i,k)*c_cld_tau(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w(:,i,k) = ( cldfgrau(i,k)*grau_tau_w(:,i,k) & - + cld(i,k)*c_cld_tau_w(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_g(:,i,k) = ( cldfgrau(i,k)*grau_tau_w_g(:,i,k) & - + cld(i,k)*c_cld_tau_w_g(:,i,k) )/cldfprime(i,k) - else - c_cld_tau(:,i,k) = 0._r8 - c_cld_tau_w(:,i,k) = 0._r8 - c_cld_tau_w_g(:,i,k) = 0._r8 - end if - end do - end do - end if - - ! cloud optical properties need to be re-ordered from the RRTMG spectral bands - ! (assumed in the optics datasets) to RRTMGP's - ice_tau(:,:ncol,:) = ice_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) - liq_tau(:,:ncol,:) = liq_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) - c_cld_tau(:,:ncol,:) = c_cld_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) - c_cld_tau_w(:,:ncol,:) = c_cld_tau_w(rrtmg_to_rrtmgp_swbands,:ncol,:) - c_cld_tau_w_g(:,:ncol,:) = c_cld_tau_w_g(rrtmg_to_rrtmgp_swbands,:ncol,:) - if (cldfsnow_idx > 0) then - snow_tau(:,:ncol,:) = snow_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) - end if - if (cldfgrau_idx > 0 .and. graupel_in_rad) then - grau_tau(:,:ncol,:) = grau_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) - end if - ! Set cloud optical properties in cloud_sw object. call rrtmgp_set_cloud_sw( & - nday, nlay, idxday, pmid_day, cldfprime, & - c_cld_tau, c_cld_tau_w, c_cld_tau_w_g, kdist_sw, cloud_sw) - - ! SW cloud diagnostics & output - - ! cloud optical depth fields for the visible band - rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) - rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) - rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) - if (cldfsnow_idx > 0) then - rd%snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) - endif - if (cldfgrau_idx > 0 .and. graupel_in_rad) then - rd%grau_icld_vistau(:ncol,:) = grau_tau(idx_sw_diag,:ncol,:) - endif - - ! multiply by total cloud fraction to get gridbox value - rd%tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) - - ! add fillvalue for night columns - do i = 1, Nnite - rd%tot_cld_vistau(IdxNite(i),:) = fillvalue - rd%tot_icld_vistau(IdxNite(i),:) = fillvalue - rd%liq_icld_vistau(IdxNite(i),:) = fillvalue - rd%ice_icld_vistau(IdxNite(i),:) = fillvalue - if (cldfsnow_idx > 0) then - rd%snow_icld_vistau(IdxNite(i),:) = fillvalue - end if - if (cldfgrau_idx > 0 .and. graupel_in_rad) then - rd%grau_icld_vistau(IdxNite(i),:) = fillvalue - end if - end do + state, pbuf, nlay, nday, idxday, & + nnite, idxnite, pmid_day, cld, cldfsnow, & + cldfgrau, cldfprime, graupel_in_rad, kdist_sw, cloud_sw, & + rd%tot_cld_vistau, rd%tot_icld_vistau, rd%liq_icld_vistau, & + rd%ice_icld_vistau, rd%snow_icld_vistau, rd%grau_icld_vistau, & + cld_tau_cloudsim, snow_tau_cloudsim, grau_tau_cloudsim ) if (write_output) then call radiation_output_cld(lchnk, ncol, rd) @@ -1374,7 +1213,6 @@ subroutine radiation_tend( & end if ! Init and allocate arrays in aerosol optics object. - errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber()) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: aer_sw%alloc_2str: '//trim(errmsg)) @@ -1402,23 +1240,9 @@ subroutine radiation_tend( & tsi_ref = sum(toa_flux(1,:)) toa_flux = toa_flux * sol_tsi * eccf / tsi_ref - ! Get aerosol shortwave optical properties on CAM grid. - call aer_rad_props_sw( & - icall, state, pbuf, nnite, idxnite, & - aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) - - ! aerosol optical properties need to be re-ordered from the RRTMG spectral bands, - ! as assumed in the optics datasets, to the RRTMGP band order. - aer_tau(:,:,:) = aer_tau(:,:,rrtmg_to_rrtmgp_swbands) - aer_tau_w(:,:,:) = aer_tau_w(:,:,rrtmg_to_rrtmgp_swbands) - aer_tau_w_g(:,:,:) = aer_tau_w_g(:,:,rrtmg_to_rrtmgp_swbands) - aer_tau_w_f(:,:,:) = aer_tau_w_f(:,:,rrtmg_to_rrtmgp_swbands) - - ! Convert from the products to individual properties, - ! and only provide them on the daylit points. + ! Set SW aerosol optical properties in the aer_sw object. call rrtmgp_set_aer_sw( & - nday, idxday, aer_tau, aer_tau_w, aer_tau_w_g, & - aer_tau_w_f, aer_sw) + icall, state, pbuf, nday, idxday, nnite, idxnite, aer_sw) ! Increment the gas optics (in atm_optics_sw) by the aerosol optics in aer_sw. errmsg = aer_sw%increment(atm_optics_sw) @@ -1470,30 +1294,12 @@ subroutine radiation_tend( & if (dolw) then - if (oldcldoptics) then - call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) - else - select case (icecldoptics) - case ('ebertcurry') - call ec_ice_get_rad_props_lw(state, pbuf, ice_lw_abs, oldicewp=.true.) - case ('mitchell') - call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) - case default - call endrun('ERROR: icecldoptics must be one either ebertcurry or mitchell') - end select - - select case (liqcldoptics) - case ('slingo') - call slingo_liq_get_rad_props_lw(state, pbuf, liq_lw_abs, oldliqwp=.true.) - case ('gammadist') - call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) - case default - call endrun('ERROR: liqcldoptics must be either slingo or gammadist') - end select - - cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) + call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) + + call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) + + cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) - end if if (cldfsnow_idx > 0) then ! add in snow @@ -1632,12 +1438,12 @@ subroutine radiation_tend( & ! Add graupel to snow tau for cosp if (cldfgrau_idx > 0 .and. graupel_in_rad) then - gb_snow_tau(i,k) = snow_tau(idx_sw_cloudsim,i,k)*cldfsnow(i,k) + & - grau_tau(idx_sw_cloudsim,i,k)*cldfgrau(i,k) + gb_snow_tau(i,k) = snow_tau_cloudsim(i,k)*cldfsnow(i,k) + & + grau_tau_cloudsim(i,k)*cldfgrau(i,k) gb_snow_lw(i,k) = snow_lw_abs(idx_lw_cloudsim,i,k)*cldfsnow(i,k) + & - grau_lw_abs(idx_lw_cloudsim,i,k)*cldfgrau(i,k) + grau_lw_abs(idx_lw_cloudsim,i,k)*cldfgrau(i,k) else - gb_snow_tau(i,k) = snow_tau(idx_sw_cloudsim,i,k)*cldfsnow(i,k) + gb_snow_tau(i,k) = snow_tau_cloudsim(i,k)*cldfsnow(i,k) gb_snow_lw(i,k) = snow_lw_abs(idx_lw_cloudsim,i,k)*cldfsnow(i,k) end if end if @@ -1654,7 +1460,7 @@ subroutine radiation_tend( & ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave ! optical depths are passed. call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & - cld_swtau_in=cld_tau(idx_sw_cloudsim,:,:),& + cld_swtau_in=cld_tau_cloudsim,& snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) cosp_cnt(lchnk) = 0 end if diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 1fc3e30094..f076f4c1e0 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -17,17 +17,26 @@ module rrtmgp_inputs use physics_buffer, only: physics_buffer_desc use camsrfexch, only: cam_in_t -use radconstants, only: nswbands, nlwbands, get_sw_spectral_boundaries +use radconstants, only: nswbands, nlwbands, nswgpts, get_sw_spectral_boundaries, & + idx_sw_diag, idx_sw_cloudsim use radconstants, only: nradgas, gaslist use rad_constituents, only: rad_cnst_get_gas +use cloud_rad_props, only: get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & + get_ice_optics_sw, ice_cloud_get_rad_props_lw, & + get_snow_optics_sw, snow_cloud_get_rad_props_lw, & + get_grau_optics_sw, grau_cloud_get_rad_props_lw + use mcica_subcol_gen, only: mcica_subcol_sw, mcica_subcol_lw +use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw + use mo_gas_concentrations, only: ty_gas_concs use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_optical_props, only: ty_optical_props_2str, ty_optical_props_1scl +use cam_history_support, only: fillvalue use cam_logfile, only: iulog use cam_abortutils, only: endrun @@ -45,7 +54,10 @@ module rrtmgp_inputs rrtmgp_set_aer_lw, & rrtmgp_set_aer_sw -real(r8), parameter :: cldmin = 1.0e-80_r8 ! min cloud fraction + +! This value is to match the arbitrary small value used in RRTMG to decide +! when a quantity is effectively zero. +real(r8), parameter :: tiny = 1.0e-80_r8 ! Indices for copying data between cam and rrtmgp arrays integer :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which @@ -56,6 +68,12 @@ module rrtmgp_inputs ! wavenumber (cm^-1) boundaries of shortwave bands real(r8) :: sw_low_bounds(nswbands), sw_high_bounds(nswbands) +! Mapping from RRTMG shortwave bands to RRTMGP. Currently needed to continue using +! the SW optics datasets from RRTMG (even thought there is a slight mismatch in the +! band boundaries of the 2 bands that overlap with the LW bands). +integer, parameter, dimension(14) :: rrtmg_to_rrtmgp_swbands = & + [ 14, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13 ] + !================================================================================================== contains !================================================================================================== @@ -504,40 +522,77 @@ end subroutine rrtmgp_set_cloud_lw !================================================================================================== subroutine rrtmgp_set_cloud_sw( & - nday, nlay, idxday, pmid, cldfrac, & - c_cld_tau, c_cld_tau_w, c_cld_tau_w_g, kdist_sw, cloud_sw) + state, pbuf, nlay, nday, idxday, & + nnite, idxnite, pmid, cld, cldfsnow, & + cldfgrau, cldfprime, graupel_in_rad, kdist_sw, cloud_sw, & + tot_cld_vistau, tot_icld_vistau, liq_icld_vistau, ice_icld_vistau, snow_icld_vistau, & + grau_icld_vistau, cld_tau_cloudsim, snow_tau_cloudsim, grau_tau_cloudsim) + ! Compute combined cloud optical properties. ! Create MCICA stochastic arrays for cloud SW optical properties. ! Initialize optical properties object (cloud_sw) and load with MCICA columns. - ! - ! The input optical properties are on the CAM grid and are represented as products - ! of the extinction optical depth (tau), single scattering albedo (w) and assymetry - ! parameter (g). This routine subsets the input to just the layers and the - ! daylight columns used in the radiation calculation. It also computes the - ! individual properties of tau, w, and g for input to the MCICA routine. ! arguments - integer, intent(in) :: nday ! number of daylight columns + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) integer, intent(in) :: nlay ! number of layers in radiation calculation (may include "extra layer") - integer, intent(in) :: idxday(:) ! indices of daylight columns in the chunk + integer, intent(in) :: nday ! number of daylight columns + integer, intent(in) :: idxday(pcols) ! indices of daylight columns in the chunk + integer, intent(in) :: nnite ! number of night columns + integer, intent(in) :: idxnite(pcols) ! indices of night columns in the chunk + real(r8), intent(in) :: pmid(nday,nlay)! pressure at layer midpoints (Pa) used to seed RNG. - ! cloud fraction and optics are input on the CAM grid - real(r8), intent(in) :: cldfrac(pcols,pver) ! combined cloud fraction - real(r8), intent(in) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth - real(r8), intent(in) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau - real(r8), intent(in) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau + real(r8), pointer :: cld(:,:) ! cloud fraction (liq+ice) + real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds" + real(r8), pointer :: cldfgrau(:,:) ! cloud fraction of just "graupel clouds" + real(r8), intent(in) :: cldfprime(pcols,pver) ! combined cloud fraction + logical, intent(in) :: graupel_in_rad ! graupel in radiation code class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! shortwave gas optics object - type(ty_optical_props_2str), intent(out) :: cloud_sw ! cloud optical properties object - - ! local vars + type(ty_optical_props_2str), intent(out) :: cloud_sw ! SW cloud optical properties object + + ! Diagnostic outputs + real(r8), intent(out) :: tot_cld_vistau(pcols,pver) ! gbx total cloud optical depth + real(r8), intent(out) :: tot_icld_vistau(pcols,pver) ! in-cld total cloud optical depth + real(r8), intent(out) :: liq_icld_vistau(pcols,pver) ! in-cld liq cloud optical depth + real(r8), intent(out) :: ice_icld_vistau(pcols,pver) ! in-cld ice cloud optical depth + real(r8), intent(out) :: snow_icld_vistau(pcols,pver) ! snow in-cloud visible sw optical depth + real(r8), intent(out) :: grau_icld_vistau(pcols,pver) ! Graupel in-cloud visible sw optical depth + real(r8), intent(out) :: cld_tau_cloudsim(pcols,pver) ! in-cloud liq+ice optical depth (for COSP) + real(r8), intent(out) :: snow_tau_cloudsim(pcols,pver)! in-cloud snow optical depth (for COSP) + real(r8), intent(out) :: grau_tau_cloudsim(pcols,pver)! in-cloud Graupel optical depth (for COSP) + + ! Local variables + + integer :: i, k, ncol + integer :: igpt, nver integer, parameter :: changeseed = 1 - integer :: i, k, kk, ns, igpt - integer :: ngptsw - integer :: nver - + ! 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) :: 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) :: 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) :: 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) :: 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) :: 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 + + ! RRTMGP does not use this property in its 2-stream calculations. + real(r8) :: sw_tau_w_f(nswbands,pcols,pver) ! Forward scattered fraction * tau * w. + + ! Arrays for converting from CAM chunks to RRTMGP inputs. real(r8), allocatable :: cldf(:,:) real(r8), allocatable :: tauc(:,:,:) real(r8), allocatable :: ssac(:,:,:) @@ -545,8 +600,6 @@ subroutine rrtmgp_set_cloud_sw( & real(r8), allocatable :: taucmcl(:,:,:) real(r8), allocatable :: ssacmcl(:,:,:) real(r8), allocatable :: asmcmcl(:,:,:) - - real(r8) :: small_val = 1.e-80_r8 real(r8), allocatable :: day_cld_tau(:,:,:) real(r8), allocatable :: day_cld_tau_w(:,:,:) real(r8), allocatable :: day_cld_tau_w_g(:,:,:) @@ -555,27 +608,128 @@ subroutine rrtmgp_set_cloud_sw( & character(len=*), parameter :: sub = 'rrtmgp_set_cloud_sw' !-------------------------------------------------------------------------------- - ! number of g-points. This is the number of subcolumns constructed by MCICA. - ngptsw = kdist_sw%get_ngpt() + ncol = state%ncol + + ! Combine the cloud optical properties. These calculations are done on CAM "chunks". + + ! gammadist liquid optics + call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, sw_tau_w_f) + ! Mitchell ice optics + call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, sw_tau_w_f) + + cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) + cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) + cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) + + ! add in snow + if (associated(cldfsnow)) then + call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, sw_tau_w_f) + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0.) then + c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & + + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) + c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & + + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) + c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & + + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) + else + c_cld_tau(:,i,k) = 0._r8 + c_cld_tau_w(:,i,k) = 0._r8 + c_cld_tau_w_g(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) + c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) + c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) + end if + + ! add in graupel + if (associated(cldfgrau) .and. graupel_in_rad) then + call get_grau_optics_sw(state, pbuf, grau_tau, grau_tau_w, grau_tau_w_g, sw_tau_w_f) + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0._r8) then + c_cld_tau(:,i,k) = ( cldfgrau(i,k)*grau_tau(:,i,k) & + + cld(i,k)*c_cld_tau(:,i,k) )/cldfprime(i,k) + c_cld_tau_w(:,i,k) = ( cldfgrau(i,k)*grau_tau_w(:,i,k) & + + cld(i,k)*c_cld_tau_w(:,i,k) )/cldfprime(i,k) + c_cld_tau_w_g(:,i,k) = ( cldfgrau(i,k)*grau_tau_w_g(:,i,k) & + + cld(i,k)*c_cld_tau_w_g(:,i,k) )/cldfprime(i,k) + else + c_cld_tau(:,i,k) = 0._r8 + c_cld_tau_w(:,i,k) = 0._r8 + c_cld_tau_w_g(:,i,k) = 0._r8 + end if + end do + end do + end if + + ! cloud optical properties need to be re-ordered from the RRTMG spectral bands + ! (assumed in the optics datasets) to RRTMGP's + ice_tau(:,:ncol,:) = ice_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + liq_tau(:,:ncol,:) = liq_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + c_cld_tau(:,:ncol,:) = c_cld_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + c_cld_tau_w(:,:ncol,:) = c_cld_tau_w(rrtmg_to_rrtmgp_swbands,:ncol,:) + c_cld_tau_w_g(:,:ncol,:) = c_cld_tau_w_g(rrtmg_to_rrtmgp_swbands,:ncol,:) + if (associated(cldfsnow)) then + snow_tau(:,:ncol,:) = snow_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + end if + if (associated(cldfgrau) .and. graupel_in_rad) then + grau_tau(:,:ncol,:) = grau_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + end if + + ! Set arrays for diagnostic output. + ! cloud optical depth fields for the visible band + tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) + liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) + ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) + if (associated(cldfsnow)) then + snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) + endif + if (associated(cldfgrau) .and. graupel_in_rad) then + grau_icld_vistau(:ncol,:) = grau_tau(idx_sw_diag,:ncol,:) + endif + + ! multiply by total cloud fraction to get gridbox value + tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) + + ! overwrite night columns with fillvalue + do i = 1, Nnite + tot_cld_vistau(IdxNite(i),:) = fillvalue + tot_icld_vistau(IdxNite(i),:) = fillvalue + liq_icld_vistau(IdxNite(i),:) = fillvalue + ice_icld_vistau(IdxNite(i),:) = fillvalue + if (associated(cldfsnow)) then + snow_icld_vistau(IdxNite(i),:) = fillvalue + end if + if (associated(cldfgrau) .and. graupel_in_rad) then + grau_icld_vistau(IdxNite(i),:) = fillvalue + end if + end do + + ! Cloud optics for COSP + cld_tau_cloudsim = cld_tau(idx_sw_cloudsim,:,:) + snow_tau_cloudsim = snow_tau(idx_sw_cloudsim,:,:) + grau_tau_cloudsim = grau_tau(idx_sw_cloudsim,:,:) ! number of CAM's layers in radiation calculation. Does not include the "extra layer". - nver = pver - ktopcam + 1 + nver = pver - ktopcam + 1 allocate( & - cldf(nday,nver), & - tauc(nswbands,nday,nver), & - ssac(nswbands,nday,nver), & - asmc(nswbands,nday,nver), & - taucmcl(ngptsw,nday,nver), & - ssacmcl(ngptsw,nday,nver), & - asmcmcl(ngptsw,nday,nver), & - day_cld_tau(nswbands,nday,nver), & - day_cld_tau_w(nswbands,nday,nver), & - day_cld_tau_w_g(nswbands,nday,nver)) - - ! Subset the input data so just the daylight columns, and the number of CAM layers in the + cldf(nday,nver), & + day_cld_tau(nswbands,nday,nver), & + day_cld_tau_w(nswbands,nday,nver), & + day_cld_tau_w_g(nswbands,nday,nver), & + tauc(nswbands,nday,nver), taucmcl(nswgpts,nday,nver), & + ssac(nswbands,nday,nver), ssacmcl(nswgpts,nday,nver), & + asmc(nswbands,nday,nver), asmcmcl(nswgpts,nday,nver) ) + + ! Subset "chunk" data so just the daylight columns, and the number of CAM layers in the ! radiation calculation are used by MCICA to produce subcolumns. - cldf = cldfrac( idxday(1:nday), ktopcam:) + cldf = cldfprime( idxday(1:nday), ktopcam:) day_cld_tau = c_cld_tau( :, idxday(1:nday), ktopcam:) day_cld_tau_w = c_cld_tau_w( :, idxday(1:nday), ktopcam:) day_cld_tau_w_g = c_cld_tau_w_g(:, idxday(1:nday), ktopcam:) @@ -586,15 +740,15 @@ subroutine rrtmgp_set_cloud_sw( & ! set cloud optical depth, clip @ zero tauc = merge(day_cld_tau, 0.0_r8, day_cld_tau > 0.0_r8) ! set value of asymmetry - asmc = merge(day_cld_tau_w_g / max(day_cld_tau_w, small_val), 0.0_r8, day_cld_tau_w > 0.0_r8) + asmc = merge(day_cld_tau_w_g / max(day_cld_tau_w, tiny), 0.0_r8, day_cld_tau_w > 0.0_r8) ! set value of single scattering albedo - ssac = merge(max(day_cld_tau_w, small_val) / max(tauc, small_val), 1.0_r8 , tauc > 0.0_r8) + ssac = merge(max(day_cld_tau_w, tiny) / max(tauc, tiny), 1.0_r8 , tauc > 0.0_r8) ! set asymmetry to zero when tauc = 0 asmc = merge(asmc, 0.0_r8, tauc > 0.0_r8) ! MCICA converts from bands to gpts (e.g., 224 g-points instead of 14 bands) call mcica_subcol_sw( & - kdist_sw, nswbands, ngptsw, nday, nlay, & + kdist_sw, nswbands, nswgpts, nday, nlay, & nver, changeseed, pmid, cldf, tauc, & ssac, asmc, taucmcl, ssacmcl, asmcmcl) @@ -611,13 +765,13 @@ subroutine rrtmgp_set_cloud_sw( & cloud_sw%g = 0.0_r8 ! Set the properties on g-points. - do igpt = 1,ngptsw + do igpt = 1,nswgpts cloud_sw%g (:, ktoprad:, igpt) = asmcmcl(igpt, ktopcam:, :) cloud_sw%ssa(:, ktoprad:, igpt) = ssacmcl(igpt, ktopcam:, :) cloud_sw%tau(:, ktoprad:, igpt) = taucmcl(igpt, ktopcam:, :) end do - ! validate checks the tau > 0, ssa is in range [0,1], and g is in range [-1,1]. + ! validate checks that: tau > 0, ssa is in range [0,1], and g is in range [-1,1]. errmsg = cloud_sw%validate() if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: cloud_sw%validate: '//trim(errmsg)) @@ -665,69 +819,78 @@ end subroutine rrtmgp_set_aer_lw !================================================================================================== subroutine rrtmgp_set_aer_sw( & - nday, idxday, aer_tau, aer_tau_w, & - aer_tau_w_g, aer_tau_w_f, aer_sw) + icall, state, pbuf, nday, idxday, nnite, idxnite, aer_sw) ! Load aerosol SW optical properties into the RRTMGP object. - ! - ! CAM fields are products tau, tau*ssa, tau*ssa*asy, tau*ssa*asy*fsf - ! Fields expected by RRTMGP are computed by - ! aer_sw%tau = aer_tau - ! aer_sw%ssa = aer_tau_w / aer_tau - ! aer_sw%g = aer_tau_w_g / aer_taw_w - ! - ! The input optical arrays from CAM are dimensioned in the vertical - ! as 0:pver. The index 0 is for the extra layer used in the radiation - ! calculation. The index ktopcam assumes the CAM vertical indices are - ! in the range 1:pver, so using this index correctly ignores vertical - ! index 0. If an "extra" layer is used in the calculations, it is - ! provided and set in the RRTMGP aerosol object aer_sw. ! Arguments - integer, intent(in) :: nday - integer, intent(in) :: idxday(:) - real(r8), intent(in) :: aer_tau (pcols,0:pver,nswbands) ! extinction optical depth - real(r8), intent(in) :: aer_tau_w (pcols,0:pver,nswbands) ! single scattering albedo * tau - real(r8), intent(in) :: aer_tau_w_g(pcols,0:pver,nswbands) ! asymmetry parameter * w * tau - real(r8), intent(in) :: aer_tau_w_f(pcols,0:pver,nswbands) ! forward scattered fraction * w * tau + integer, intent(in) :: icall + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: nday + integer, intent(in) :: idxday(:) + integer, intent(in) :: nnite ! number of night columns + integer, intent(in) :: idxnite(pcols) ! indices of night columns in the chunk + type(ty_optical_props_2str), intent(inout) :: aer_sw ! local variables - integer :: i + integer :: i, k, ib - ! minimum value for aer_tau_w is the same as used in RRTMG code. - real(r8), parameter :: tiny = 1.e-80_r8 - - character(len=32) :: sub = 'rrtmgp_set_aer_sw' + ! The optical arrays dimensioned in the vertical as 0:pver. + ! The index 0 is for the extra layer used in the radiation + ! calculation. The index ktopcam assumes the CAM vertical indices are + ! in the range 1:pver, so using this index correctly ignores vertical + ! index 0. If an "extra" layer is used in the calculations, it is + ! provided and set in the RRTMGP aerosol object aer_sw. + real(r8) :: aer_tau (pcols,0:pver,nswbands) ! extinction optical depth + real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! single scattering albedo * tau + real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! asymmetry parameter * w * tau + real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! forward scattered fraction * w * tau + ! aer_tau_w_f is not used by RRTMGP. + character(len=*), parameter :: sub = 'rrtmgp_set_aer_sw' character(len=128) :: errmsg !-------------------------------------------------------------------------------- + ! Get aerosol shortwave optical properties. + call aer_rad_props_sw( & + icall, state, pbuf, nnite, idxnite, & + aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) + + ! aerosol optical properties need to be re-ordered from the RRTMG spectral bands + ! (as assumed in the optics datasets) to the RRTMGP band order. + aer_tau(:,:,:) = aer_tau( :,:,rrtmg_to_rrtmgp_swbands) + aer_tau_w(:,:,:) = aer_tau_w( :,:,rrtmg_to_rrtmgp_swbands) + aer_tau_w_g(:,:,:) = aer_tau_w_g(:,:,rrtmg_to_rrtmgp_swbands) + ! If there is an extra layer in the radiation then this initialization - ! will provide default values there. + ! will provide default values. aer_sw%tau = 0.0_r8 aer_sw%ssa = 1.0_r8 aer_sw%g = 0.0_r8 + ! CAM fields are products tau, tau*ssa, tau*ssa*asy + ! Fields expected by RRTMGP are computed by + ! aer_sw%tau = aer_tau + ! aer_sw%ssa = aer_tau_w / aer_tau + ! aer_sw%g = aer_tau_w_g / aer_taw_w + ! aer_sw arrays have dimensions of (nday,nlay,nswbands) + do i = 1, nday - ! aer_sw arrays have dimensions of (nday,nlay,nswbands) + ! set aerosol optical depth, clip to zero aer_sw%tau(i,ktoprad:,:) = max(aer_tau(idxday(i),ktopcam:,:), 0._r8) + ! set value of single scattering albedo aer_sw%ssa(i,ktoprad:,:) = merge(aer_tau_w(idxday(i),ktopcam:,:)/aer_tau(idxday(i),ktopcam:,:), & 1._r8, aer_tau(idxday(i),ktopcam:,:) > 0._r8) + ! set value of asymmetry aer_sw%g(i,ktoprad:,:) = merge(aer_tau_w_g(idxday(i),ktopcam:,:)/aer_tau_w(idxday(i),ktopcam:,:), & 0._r8, aer_tau_w(idxday(i),ktopcam:,:) > tiny) end do - ! impose limits on the components: + ! impose limits on the components aer_sw%ssa = min(max(aer_sw%ssa, 0._r8), 1._r8) - aer_sw%g = min(max(aer_sw%g, -1._r8), 1._r8) - ! by clamping the values here, the validate method should be guaranteed to succeed, - ! but we're also saying that any errors in the method to this point are being swept aside. - ! We might want to check for out-of-bounds values and report them in the log file. + aer_sw%g = min(max(aer_sw%g, -1._r8), 1._r8) - errmsg = aer_sw%validate() - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: aer_sw%validate: '//trim(errmsg)) - end if end subroutine rrtmgp_set_aer_sw !================================================================================================== From b7f0039da88eac6cbdaf1483be5bee0cced06760 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 25 Sep 2023 12:01:01 -0400 Subject: [PATCH 33/53] refactor SW treatment of no daylight columns in chunk --- src/physics/rrtmgp/radiation.F90 | 177 ++++++++++++----------- src/physics/rrtmgp/rrtmgp_inputs.F90 | 207 ++++++++++++++------------- 2 files changed, 204 insertions(+), 180 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index bd8ec09e05..c7d305f371 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -91,8 +91,6 @@ module radiation real(r8) :: qrsc(pcols,pver) - real(r8) :: flux_sw_net_top(pcols) ! net shortwave flux at top (FSNT) - real(r8) :: fsnsc(pcols) ! Clear sky surface abs solar flux real(r8) :: fsntc(pcols) ! Clear sky total column abs solar flux real(r8) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux @@ -1145,19 +1143,11 @@ subroutine radiation_tend( & ! and would get whatever is in pbuf for qrl / qrs. ! To avoid non-daylit columns ! from having shortwave heating, we should reset here: - if (nday == 0) then - qrs(1:ncol,1:pver) = 0._r8 - rd%qrsc(1:ncol,1:pver) = 0._r8 ! this is what gets turned into QRSC in output (probably not needed here.) - dosw = .false. - end if - - ! On first time step, do we need to initialize the heating rates in pbuf? - ! what about on a restart? - if (get_nstep() == 0) then - qrs = 0._r8 - qrl = 0._r8 - end if - +! if (nday == 0) then +! qrs(1:ncol,1:pver) = 0._r8 +! rd%qrsc(1:ncol,1:pver) = 0._r8 ! this is what gets turned into QRSC in output (probably not needed here.) +! dosw = .false. +! end if if (dosw .or. dolw) then @@ -1200,76 +1190,91 @@ subroutine radiation_tend( & call radiation_output_cld(lchnk, ncol, rd) end if - ! Initialize object for gas concentrations. - errmsg = gas_concs_sw%init(gaslist_lc) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: gas_concs_sw%init: '//trim(errmsg)) - end if + ! If no daylight columns, can't create empty RRTMGP objects + if (nday > 0) then - ! Init and allocate arrays in atm optics object. - errmsg = atm_optics_sw%alloc_2str(nday, nlay, kdist_sw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: gas_optics_sw%alloc_2str: '//trim(errmsg)) - end if + ! Initialize object for gas concentrations. + errmsg = gas_concs_sw%init(gaslist_lc) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: gas_concs_sw%init: '//trim(errmsg)) + end if + + ! Init and allocate arrays in atm optics object. + errmsg = atm_optics_sw%alloc_2str(nday, nlay, kdist_sw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: gas_optics_sw%alloc_2str: '//trim(errmsg)) + end if + + ! Init and allocate arrays in aerosol optics object. + errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber()) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: aer_sw%alloc_2str: '//trim(errmsg)) + end if - ! Init and allocate arrays in aerosol optics object. - errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber()) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: aer_sw%alloc_2str: '//trim(errmsg)) end if ! The climate (icall==0) calculation must occur last. do icall = N_DIAG, 0, -1 if (active_calls(icall)) then - ! Set gas volume mixing ratios for this call in gas_concs_sw. - call rrtmgp_set_gases_sw( & - icall, state, pbuf, nlay, nday, & - idxday, gas_concs_sw) + if (nday > 0) then - ! Compute the gas optics (stored in atm_optics_sw). - ! toa_flux is the reference solar source from RRTMGP data. - errmsg = kdist_sw%gas_optics( & - pmid_day, pint_day, t_day, gas_concs_sw, atm_optics_sw, & - toa_flux) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: kdist_sw%gas_optics: '//trim(errmsg)) - end if + ! Set gas volume mixing ratios for this call in gas_concs_sw. + call rrtmgp_set_gases_sw( & + icall, state, pbuf, nlay, nday, & + idxday, gas_concs_sw) + + ! Compute the gas optics (stored in atm_optics_sw). + ! toa_flux is the reference solar source from RRTMGP data. + errmsg = kdist_sw%gas_optics( & + pmid_day, pint_day, t_day, gas_concs_sw, atm_optics_sw, & + toa_flux) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: kdist_sw%gas_optics: '//trim(errmsg)) + end if - ! Scale the solar source - tsi_ref = sum(toa_flux(1,:)) - toa_flux = toa_flux * sol_tsi * eccf / tsi_ref + ! Scale the solar source + tsi_ref = sum(toa_flux(1,:)) + toa_flux = toa_flux * sol_tsi * eccf / tsi_ref + + end if ! Set SW aerosol optical properties in the aer_sw object. + ! This call made even when no daylight columns because it does some + ! diagnostic aerosol output. call rrtmgp_set_aer_sw( & icall, state, pbuf, nday, idxday, nnite, idxnite, aer_sw) - ! Increment the gas optics (in atm_optics_sw) by the aerosol optics in aer_sw. - errmsg = aer_sw%increment(atm_optics_sw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in aer_sw%increment: '//trim(errmsg)) - end if + if (nday > 0) then - ! Compute clear-sky fluxes. - errmsg = rte_sw(& - atm_optics_sw, top_at_1, coszrs_day, toa_flux, & - alb_dir, alb_dif, fswc) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in clear-sky rte_sw: '//trim(errmsg)) - end if + ! Increment the gas optics (in atm_optics_sw) by the aerosol optics in aer_sw. + errmsg = aer_sw%increment(atm_optics_sw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR in aer_sw%increment: '//trim(errmsg)) + end if - ! Increment the aerosol+gas optics (in atm_optics_sw) by the cloud optics in cloud_sw. - errmsg = cloud_sw%increment(atm_optics_sw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in cloud_sw%increment: '//trim(errmsg)) - end if + ! Compute clear-sky fluxes. + errmsg = rte_sw(& + atm_optics_sw, top_at_1, coszrs_day, toa_flux, & + alb_dir, alb_dif, fswc) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR in clear-sky rte_sw: '//trim(errmsg)) + end if + + ! Increment the aerosol+gas optics (in atm_optics_sw) by the cloud optics in cloud_sw. + errmsg = cloud_sw%increment(atm_optics_sw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR in cloud_sw%increment: '//trim(errmsg)) + end if + + ! Compute all-sky fluxes. + errmsg = rte_sw(& + atm_optics_sw, top_at_1, coszrs_day, toa_flux, & + alb_dir, alb_dif, fsw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR in all-sky rte_sw: '//trim(errmsg)) + end if - ! Compute all-sky fluxes. - errmsg = rte_sw(& - atm_optics_sw, top_at_1, coszrs_day, toa_flux, & - alb_dir, alb_dif, fsw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in all-sky rte_sw: '//trim(errmsg)) end if ! Transform RRTMGP outputs to CAM outputs and compute heating rates. @@ -1549,20 +1554,31 @@ subroutine set_sw_diags() !------------------------------------------------------------------------- ! Initialize to provide 0.0 values for night columns. - fns = 0._r8 ! net sw flux - fcns = 0._r8 ! net sw clearsky flux - fsds = 0._r8 ! downward sw flux at surface - rd%fsdsc = 0._r8 ! downward sw clearsky flux at surface - rd%fsutoa = 0._r8 ! upward sw flux at TOA - rd%fsntoa = 0._r8 ! net sw at TOA - rd%fsntoac = 0._r8 ! net sw clearsky flux at TOA - rd%solin = 0._r8 ! solar irradiance at TOA + fns = 0._r8 ! net sw flux + fcns = 0._r8 ! net sw clearsky flux + fsds = 0._r8 ! downward sw flux at surface + rd%fsdsc = 0._r8 ! downward sw clearsky flux at surface + rd%fsutoa = 0._r8 ! upward sw flux at TOA + rd%fsntoa = 0._r8 ! net sw at TOA + rd%fsntoac = 0._r8 ! net sw clearsky flux at TOA + rd%solin = 0._r8 ! solar irradiance at TOA + rd%flux_sw_up = 0._r8 + rd%flux_sw_dn = 0._r8 + rd%flux_sw_clr_up = 0._r8 + rd%flux_sw_clr_dn = 0._r8 + rd%fsdn = 0._r8 rd%fsdnc = 0._r8 rd%fsup = 0._r8 rd%fsupc = 0._r8 - ! fns, fcns, rd are on CAM grid (do not have "extra layer" when it is present.) + qrs = 0._r8 + fsns = 0._r8 + fsnt = 0._r8 + rd%qrsc = 0._r8 + rd%fsnsc = 0._r8 + rd%fsntc = 0._r8 + do i = 1, nday fns(idxday(i),ktopcam:) = fsw%flux_net(i, ktoprad:) fcns(idxday(i),ktopcam:) = fswc%flux_net(i,ktoprad:) @@ -1576,18 +1592,19 @@ subroutine set_sw_diags() rd%flux_sw_dn(idxday(i),ktopcam:) = fsw%flux_dn(i,ktoprad:) rd%flux_sw_clr_up(idxday(i),ktopcam:) = fswc%flux_up(i,ktoprad:) rd%flux_sw_clr_dn(idxday(i),ktopcam:) = fswc%flux_dn(i,ktoprad:) + rd%fsdn(idxday(i),:) = fsw%flux_dn(i,:) rd%fsdnc(idxday(i),:) = fswc%flux_dn(i,:) rd%fsup(idxday(i),:) = fsw%flux_up(i,:) rd%fsupc(idxday(i),:) = fswc%flux_up(i,:) end do + ! Compute heating rate as a dry static energy tendency. call heating_rate('SW', ncol, fns, qrs) call heating_rate('SW', ncol, fcns, rd%qrsc) fsns(:ncol) = fns(:ncol,pverp) ! net sw flux at surface fsnt(:ncol) = fns(:ncol,1) ! net sw flux at top-of-model (w/o extra layer) - rd%flux_sw_net_top(:ncol) = fns(:ncol, 1) rd%fsnsc(:ncol) = fcns(:ncol,pverp) ! net sw clearsky flux at surface rd%fsntc(:ncol) = fcns(:ncol,1) ! net sw clearsky flux at top @@ -1614,7 +1631,6 @@ subroutine set_sw_diags() ! Export surface fluxes ! sols(pcols) Direct solar rad on surface (< 0.7) ! soll(pcols) Direct solar rad on surface (>= 0.7) - ! RRTMG: Near-IR bands (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns ! RRTMGP: Near-IR bands (1-10), 820-16000 cm-1, 0.625-12.195 microns ! Put half of band 10 in each of the UV/visible and near-IR values, ! since this band straddles 0.7 microns: @@ -1630,8 +1646,6 @@ subroutine set_sw_diags() flux_dn_diffuse = fsw%bnd_flux_dn - fsw%bnd_flux_dn_dir do i = 1, nday - ! These use hard-coded indexes assuming default RRTMGP sw bands - ! Should be generalized to use specified frequencies. cam_out%soll(idxday(i)) = sum(fsw%bnd_flux_dn_dir(i,nlay+1,1:9)) & + 0.5_r8 * fsw%bnd_flux_dn_dir(i,nlay+1,10) @@ -1643,7 +1657,6 @@ subroutine set_sw_diags() cam_out%solsd(idxday(i)) = 0.5_r8 * flux_dn_diffuse(i, nlay+1, 10) & + sum(flux_dn_diffuse(i,nlay+1,11:14)) - end do end subroutine set_sw_diags @@ -1779,7 +1792,7 @@ subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) - call outfld('FSNT'//diag(icall), rd%flux_sw_net_top, pcols, lchnk) + call outfld('FSNT'//diag(icall), fsnt, pcols, lchnk) call outfld('FSNTC'//diag(icall), rd%fsntc, pcols, lchnk) call outfld('FSNTOA'//diag(icall), rd%fsntoa, pcols, lchnk) call outfld('FSNTOAC'//diag(icall), rd%fsntoac, pcols, lchnk) diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index f076f4c1e0..fc6c5d4c4e 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -715,79 +715,84 @@ subroutine rrtmgp_set_cloud_sw( & snow_tau_cloudsim = snow_tau(idx_sw_cloudsim,:,:) grau_tau_cloudsim = grau_tau(idx_sw_cloudsim,:,:) - ! number of CAM's layers in radiation calculation. Does not include the "extra layer". - nver = pver - ktopcam + 1 - - allocate( & - cldf(nday,nver), & - day_cld_tau(nswbands,nday,nver), & - day_cld_tau_w(nswbands,nday,nver), & - day_cld_tau_w_g(nswbands,nday,nver), & - tauc(nswbands,nday,nver), taucmcl(nswgpts,nday,nver), & - ssac(nswbands,nday,nver), ssacmcl(nswgpts,nday,nver), & - asmc(nswbands,nday,nver), asmcmcl(nswgpts,nday,nver) ) - - ! Subset "chunk" data so just the daylight columns, and the number of CAM layers in the - ! radiation calculation are used by MCICA to produce subcolumns. - cldf = cldfprime( idxday(1:nday), ktopcam:) - day_cld_tau = c_cld_tau( :, idxday(1:nday), ktopcam:) - day_cld_tau_w = c_cld_tau_w( :, idxday(1:nday), ktopcam:) - day_cld_tau_w_g = c_cld_tau_w_g(:, idxday(1:nday), ktopcam:) - - ! Compute the optical properties needed for the 2-stream calculations. These calculations - ! are the same as the RRTMG version. - - ! set cloud optical depth, clip @ zero - tauc = merge(day_cld_tau, 0.0_r8, day_cld_tau > 0.0_r8) - ! set value of asymmetry - asmc = merge(day_cld_tau_w_g / max(day_cld_tau_w, tiny), 0.0_r8, day_cld_tau_w > 0.0_r8) - ! set value of single scattering albedo - ssac = merge(max(day_cld_tau_w, tiny) / max(tauc, tiny), 1.0_r8 , tauc > 0.0_r8) - ! set asymmetry to zero when tauc = 0 - asmc = merge(asmc, 0.0_r8, tauc > 0.0_r8) - - ! MCICA converts from bands to gpts (e.g., 224 g-points instead of 14 bands) - call mcica_subcol_sw( & - kdist_sw, nswbands, nswgpts, nday, nlay, & - nver, changeseed, pmid, cldf, tauc, & - ssac, asmc, taucmcl, ssacmcl, asmcmcl) + ! if no daylight columns the cloud_sw object isn't initialized + if (nday > 0) then + + ! number of CAM's layers in radiation calculation. Does not include the "extra layer". + nver = pver - ktopcam + 1 + + allocate( & + cldf(nday,nver), & + day_cld_tau(nswbands,nday,nver), & + day_cld_tau_w(nswbands,nday,nver), & + day_cld_tau_w_g(nswbands,nday,nver), & + tauc(nswbands,nday,nver), taucmcl(nswgpts,nday,nver), & + ssac(nswbands,nday,nver), ssacmcl(nswgpts,nday,nver), & + asmc(nswbands,nday,nver), asmcmcl(nswgpts,nday,nver) ) + + ! Subset "chunk" data so just the daylight columns, and the number of CAM layers in the + ! radiation calculation are used by MCICA to produce subcolumns. + cldf = cldfprime( idxday(1:nday), ktopcam:) + day_cld_tau = c_cld_tau( :, idxday(1:nday), ktopcam:) + day_cld_tau_w = c_cld_tau_w( :, idxday(1:nday), ktopcam:) + day_cld_tau_w_g = c_cld_tau_w_g(:, idxday(1:nday), ktopcam:) + + ! Compute the optical properties needed for the 2-stream calculations. These calculations + ! are the same as the RRTMG version. + + ! set cloud optical depth, clip @ zero + tauc = merge(day_cld_tau, 0.0_r8, day_cld_tau > 0.0_r8) + ! set value of asymmetry + asmc = merge(day_cld_tau_w_g / max(day_cld_tau_w, tiny), 0.0_r8, day_cld_tau_w > 0.0_r8) + ! set value of single scattering albedo + ssac = merge(max(day_cld_tau_w, tiny) / max(tauc, tiny), 1.0_r8 , tauc > 0.0_r8) + ! set asymmetry to zero when tauc = 0 + asmc = merge(asmc, 0.0_r8, tauc > 0.0_r8) + + ! MCICA converts from bands to gpts (e.g., 224 g-points instead of 14 bands) + call mcica_subcol_sw( & + kdist_sw, nswbands, nswgpts, nday, nlay, & + nver, changeseed, pmid, cldf, tauc, & + ssac, asmc, taucmcl, ssacmcl, asmcmcl) - ! Initialize object for SW cloud optical properties. - errmsg = cloud_sw%alloc_2str(nday, nlay, kdist_sw) - if (len_trim(errmsg) > 0) then - call endrun(trim(sub)//': ERROR: cloud_sw%alloc_2str: '//trim(errmsg)) - end if + ! Initialize object for SW cloud optical properties. + errmsg = cloud_sw%alloc_2str(nday, nlay, kdist_sw) + if (len_trim(errmsg) > 0) then + call endrun(trim(sub)//': ERROR: cloud_sw%alloc_2str: '//trim(errmsg)) + end if - ! If there is an extra layer in the radiation then this initialization - ! will provide the optical properties there. - cloud_sw%tau = 0.0_r8 - cloud_sw%ssa = 1.0_r8 - cloud_sw%g = 0.0_r8 - - ! Set the properties on g-points. - do igpt = 1,nswgpts - cloud_sw%g (:, ktoprad:, igpt) = asmcmcl(igpt, ktopcam:, :) - cloud_sw%ssa(:, ktoprad:, igpt) = ssacmcl(igpt, ktopcam:, :) - cloud_sw%tau(:, ktoprad:, igpt) = taucmcl(igpt, ktopcam:, :) - end do + ! If there is an extra layer in the radiation then this initialization + ! will provide the optical properties there. + cloud_sw%tau = 0.0_r8 + cloud_sw%ssa = 1.0_r8 + cloud_sw%g = 0.0_r8 + + ! Set the properties on g-points. + do igpt = 1,nswgpts + cloud_sw%g (:, ktoprad:, igpt) = asmcmcl(igpt, ktopcam:, :) + cloud_sw%ssa(:, ktoprad:, igpt) = ssacmcl(igpt, ktopcam:, :) + cloud_sw%tau(:, ktoprad:, igpt) = taucmcl(igpt, ktopcam:, :) + end do - ! validate checks that: tau > 0, ssa is in range [0,1], and g is in range [-1,1]. - errmsg = cloud_sw%validate() - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: cloud_sw%validate: '//trim(errmsg)) - end if + ! validate checks that: tau > 0, ssa is in range [0,1], and g is in range [-1,1]. + errmsg = cloud_sw%validate() + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: cloud_sw%validate: '//trim(errmsg)) + end if - ! delta scaling adjusts for forward scattering - errmsg = cloud_sw%delta_scale() - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: cloud_sw%delta_scale: '//trim(errmsg)) - end if + ! delta scaling adjusts for forward scattering + errmsg = cloud_sw%delta_scale() + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: cloud_sw%delta_scale: '//trim(errmsg)) + end if + + ! All information is in cloud_sw, now deallocate local vars. + deallocate( & + cldf, tauc, ssac, asmc, & + taucmcl, ssacmcl, asmcmcl,& + day_cld_tau, day_cld_tau_w, day_cld_tau_w_g ) - ! All information is in cloud_sw, now deallocate local vars. - deallocate( & - cldf, tauc, ssac, asmc, & - taucmcl, ssacmcl, asmcmcl,& - day_cld_tau, day_cld_tau_w, day_cld_tau_w_g ) + end if end subroutine rrtmgp_set_cloud_sw @@ -853,43 +858,49 @@ subroutine rrtmgp_set_aer_sw( & !-------------------------------------------------------------------------------- ! Get aerosol shortwave optical properties. + ! Make outfld calls for aerosol optical property diagnostics. call aer_rad_props_sw( & icall, state, pbuf, nnite, idxnite, & aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) - ! aerosol optical properties need to be re-ordered from the RRTMG spectral bands - ! (as assumed in the optics datasets) to the RRTMGP band order. - aer_tau(:,:,:) = aer_tau( :,:,rrtmg_to_rrtmgp_swbands) - aer_tau_w(:,:,:) = aer_tau_w( :,:,rrtmg_to_rrtmgp_swbands) - aer_tau_w_g(:,:,:) = aer_tau_w_g(:,:,rrtmg_to_rrtmgp_swbands) + ! The aer_sw object is only initialized if nday > 0. + if (nday > 0) then + + ! aerosol optical properties need to be re-ordered from the RRTMG spectral bands + ! (as assumed in the optics datasets) to the RRTMGP band order. + aer_tau(:,:,:) = aer_tau( :,:,rrtmg_to_rrtmgp_swbands) + aer_tau_w(:,:,:) = aer_tau_w( :,:,rrtmg_to_rrtmgp_swbands) + aer_tau_w_g(:,:,:) = aer_tau_w_g(:,:,rrtmg_to_rrtmgp_swbands) - ! If there is an extra layer in the radiation then this initialization - ! will provide default values. - aer_sw%tau = 0.0_r8 - aer_sw%ssa = 1.0_r8 - aer_sw%g = 0.0_r8 - - ! CAM fields are products tau, tau*ssa, tau*ssa*asy - ! Fields expected by RRTMGP are computed by - ! aer_sw%tau = aer_tau - ! aer_sw%ssa = aer_tau_w / aer_tau - ! aer_sw%g = aer_tau_w_g / aer_taw_w - ! aer_sw arrays have dimensions of (nday,nlay,nswbands) + ! If there is an extra layer in the radiation then this initialization + ! will provide default values. + aer_sw%tau = 0.0_r8 + aer_sw%ssa = 1.0_r8 + aer_sw%g = 0.0_r8 + + ! CAM fields are products tau, tau*ssa, tau*ssa*asy + ! Fields expected by RRTMGP are computed by + ! aer_sw%tau = aer_tau + ! aer_sw%ssa = aer_tau_w / aer_tau + ! aer_sw%g = aer_tau_w_g / aer_taw_w + ! aer_sw arrays have dimensions of (nday,nlay,nswbands) + + do i = 1, nday + ! set aerosol optical depth, clip to zero + aer_sw%tau(i,ktoprad:,:) = max(aer_tau(idxday(i),ktopcam:,:), 0._r8) + ! set value of single scattering albedo + aer_sw%ssa(i,ktoprad:,:) = merge(aer_tau_w(idxday(i),ktopcam:,:)/aer_tau(idxday(i),ktopcam:,:), & + 1._r8, aer_tau(idxday(i),ktopcam:,:) > 0._r8) + ! set value of asymmetry + aer_sw%g(i,ktoprad:,:) = merge(aer_tau_w_g(idxday(i),ktopcam:,:)/aer_tau_w(idxday(i),ktopcam:,:), & + 0._r8, aer_tau_w(idxday(i),ktopcam:,:) > tiny) + end do - do i = 1, nday - ! set aerosol optical depth, clip to zero - aer_sw%tau(i,ktoprad:,:) = max(aer_tau(idxday(i),ktopcam:,:), 0._r8) - ! set value of single scattering albedo - aer_sw%ssa(i,ktoprad:,:) = merge(aer_tau_w(idxday(i),ktopcam:,:)/aer_tau(idxday(i),ktopcam:,:), & - 1._r8, aer_tau(idxday(i),ktopcam:,:) > 0._r8) - ! set value of asymmetry - aer_sw%g(i,ktoprad:,:) = merge(aer_tau_w_g(idxday(i),ktopcam:,:)/aer_tau_w(idxday(i),ktopcam:,:), & - 0._r8, aer_tau_w(idxday(i),ktopcam:,:) > tiny) - end do + ! impose limits on the components + aer_sw%ssa = min(max(aer_sw%ssa, 0._r8), 1._r8) + aer_sw%g = min(max(aer_sw%g, -1._r8), 1._r8) - ! impose limits on the components - aer_sw%ssa = min(max(aer_sw%ssa, 0._r8), 1._r8) - aer_sw%g = min(max(aer_sw%g, -1._r8), 1._r8) + end if end subroutine rrtmgp_set_aer_sw From b499cc41773f8845f700f68cf2389d58a4484697 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 28 Sep 2023 15:54:48 -0400 Subject: [PATCH 34/53] refactor LW cloud and aerosol optics, flux calc --- src/physics/rrtmgp/mcica_subcol_gen.F90 | 41 ++- src/physics/rrtmgp/radconstants.F90 | 4 +- src/physics/rrtmgp/radiation.F90 | 307 +++++++------------ src/physics/rrtmgp/rrtmgp_driver.F90 | 382 ------------------------ src/physics/rrtmgp/rrtmgp_inputs.F90 | 190 +++++++++--- 5 files changed, 280 insertions(+), 644 deletions(-) delete mode 100644 src/physics/rrtmgp/rrtmgp_driver.F90 diff --git a/src/physics/rrtmgp/mcica_subcol_gen.F90 b/src/physics/rrtmgp/mcica_subcol_gen.F90 index c77b20e4ed..f25732c729 100644 --- a/src/physics/rrtmgp/mcica_subcol_gen.F90 +++ b/src/physics/rrtmgp/mcica_subcol_gen.F90 @@ -25,16 +25,10 @@ module mcica_subcol_gen ! !---------------------------------------------------------------------------------------- -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pcols, pver, pverp -use cam_abortutils, only: endrun - -use shr_RandNum_mod, only: ShrKissRandGen - -! old: use mo_gas_optics_specification, only: ty_gas_optics_specification -! use mo_gas_optics, only: ty_gas_optics ! Wrong? +use shr_kind_mod, only: r8 => shr_kind_r8 +use ppgrid, only: pcols, pver +use shr_RandNum_mod, only: ShrKissRandGen use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp -use cam_logfile, only: iulog ! just for debugging (BPM) implicit none private @@ -47,8 +41,8 @@ module mcica_subcol_gen !======================================================================================== subroutine mcica_subcol_lw( & - kdist, nbnd, ngpt, ncol, changeseed, & - pmid, cldfrac, tauc, taucmcl) + kdist, nbnd, ngpt, ncol, nver, & + changeseed, pmid, cldfrac, tauc, taucmcl ) ! Arrays use CAM vertical index convention: index increases from top to bottom. ! This index ordering is assumed in the maximum-random overlap algorithm which starts @@ -64,15 +58,15 @@ subroutine mcica_subcol_lw( & integer, intent(in) :: nbnd ! number of spectral bands integer, intent(in) :: ngpt ! number of subcolumns (g-point intervals) integer, intent(in) :: ncol ! number of columns + integer, intent(in) :: nver ! number of layers integer, intent(in) :: changeseed ! if the subcolumn generator is called multiple times, ! permute the seed between each call. real(r8), intent(in) :: pmid(pcols,pver) ! layer pressures (Pa) - real(r8), intent(in) :: cldfrac(pcols,pver) ! layer cloud fraction - real(r8), intent(in) :: tauc(nbnd,pcols,pver) ! cloud optical depth - - real(r8), intent(out) :: taucmcl(ngpt,ncol,pver) ! subcolumn cloud optical depth [mcica] + real(r8), intent(in) :: cldfrac(ncol,nver) ! layer cloud fraction + real(r8), intent(in) :: tauc(nbnd,ncol,nver) ! cloud optical depth + real(r8), intent(out) :: taucmcl(ngpt,ncol,nver) ! subcolumn cloud optical depth [mcica] - ! Local vars + ! Local variables integer :: i, isubcol, k, n @@ -82,11 +76,12 @@ subroutine mcica_subcol_lw( & type(ShrKissRandGen) :: kiss_gen ! KISS RNG object integer :: kiss_seed(ncol,4) real(r8) :: rand_num_1d(ncol,1) ! random number (kissvec) - real(r8) :: rand_num(ncol,pver) ! random number (kissvec) + real(r8) :: rand_num(ncol,nver) ! random number (kissvec) - real(r8) :: cdf(ngpt,ncol,pver) ! random numbers - logical :: iscloudy(ngpt,ncol,pver) ! flag that says whether a gridbox is cloudy + real(r8) :: cdf(ngpt,ncol,nver) ! random numbers + logical :: iscloudy(ngpt,ncol,nver) ! flag that says whether a gridbox is cloudy !------------------------------------------------------------------------------------------ + ! clip cloud fraction cldf(:,:) = cldfrac(:ncol,:) where (cldf(:,:) < cldmin) @@ -122,7 +117,7 @@ subroutine mcica_subcol_lw( & ! - if the layer above is cloudy, use the same random number as in the layer above ! - if the layer above is clear, use a new random number - do k = 2, pver + do k = 2, nver do i = 1, ncol do isubcol = 1, ngpt if (cdf(isubcol,i,k-1) > 1._r8 - cldf(i,k-1) ) then @@ -134,14 +129,14 @@ subroutine mcica_subcol_lw( & end do end do - do k = 1, pver + do k = 1, nver iscloudy(:,:,k) = (cdf(:,:,k) >= 1._r8 - spread(cldf(:,k), dim=1, nCopies=ngpt) ) end do ! -- generate subcolumns for homogeneous clouds ----- ! where there is a cloud, set the subcolumn cloud properties; ! incoming tauc should be in-cloud quantites and not grid-averaged quantities - do k = 1,pver + do k = 1,nver do i = 1,ncol do isubcol = 1,ngpt if (iscloudy(isubcol,i,k) .and. (cldf(i,k) > 0._r8) ) then @@ -260,7 +255,6 @@ subroutine mcica_subcol_sw( & do k = 1, nver iscloudy(:,:,k) = (cdf(:,:,k) >= 1._r8 - spread(cldf(:,k), dim=1, nCopies=ngpt) ) - ! write(iulog,*) 'level ',k,' any(iscloud) = ',any(iscloudy(:,1,k)) ! BPM - Debugging - remove when done end do ! -- generate subcolumns for homogeneous clouds ----- @@ -274,7 +268,6 @@ subroutine mcica_subcol_sw( & taucmcl(isubcol,i,k) = tauc(n,i,k) ssacmcl(isubcol,i,k) = ssac(n,i,k) asmcmcl(isubcol,i,k) = asmc(n,i,k) - ! write(iulog,*) 'level ',k,' subcolumn ',isubcol, 'CLOUD! ssacmcl = ',ssacmcl(isubcol,i,k),', asmcmcl = ',asmcmcl(isubcol,i,k) ! BPM - Debugging - remove when done else taucmcl(isubcol,i,k) = 0._r8 ssacmcl(isubcol,i,k) = 1._r8 diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index 9aaca3ad1b..e414771568 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -26,8 +26,8 @@ module radconstants logical :: wavenumber_boundaries_set = .false. -integer, public, protected :: nswgpts ! # SW gpts -integer, public, protected :: nlwgpts ! # LW gpts +integer, public, protected :: nswgpts ! number of SW g-points +integer, public, protected :: nlwgpts ! number of LW g-points ! These are indices to specific bands for diagnostic output and COSP input. integer, public, protected :: idx_sw_diag = -1 ! band contains 500-nm wave diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index c7d305f371..46f108d507 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -28,8 +28,7 @@ module radiation use rrtmgp_inputs, only: rrtmgp_inputs_init use radconstants, only: nswbands, nlwbands, nswgpts, & - idx_nir_diag, idx_uv_diag, idx_lw_diag, & - idx_lw_cloudsim, nradgas, gasnamelength, gaslist, & + nradgas, gasnamelength, gaslist, & set_wavenumber_bands use cloud_rad_props, only: cloud_rad_props_init @@ -53,12 +52,12 @@ module radiation pio_def_var, pio_put_var, pio_get_var, & pio_put_att, PIO_NOWRITE, pio_closefile +use mo_source_functions, only: ty_source_func_lw use mo_gas_concentrations, only: ty_gas_concs use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str 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 @@ -877,15 +876,8 @@ subroutine radiation_tend( & rrtmgp_set_aer_lw, rrtmgp_set_gases_sw, rrtmgp_set_cloud_sw, & rrtmgp_set_aer_sw - use aer_rad_props, only: aer_rad_props_lw - - use cloud_rad_props, only: ice_cloud_get_rad_props_lw, & - liquid_cloud_get_rad_props_lw, & - snow_cloud_get_rad_props_lw, & - grau_cloud_get_rad_props_lw - ! RRTMGP drivers for flux calculations. - use rrtmgp_driver, only: rte_lw + use mo_rte_lw, only: rte_lw use mo_rte_sw, only: rte_sw use radheat, only: radheat_tend @@ -968,37 +960,43 @@ subroutine radiation_tend( & real(r8), allocatable :: alb_dir(:,:) real(r8), allocatable :: alb_dif(:,:) - real(r8) :: cld_tau_cloudsim(pcols,pver) ! in-cloud liq+ice optical depth (for COSP) - real(r8) :: snow_tau_cloudsim(pcols,pver)! in-cloud snow optical depth (for COSP) - real(r8) :: grau_tau_cloudsim(pcols,pver)! in-cloud Graupel optical depth (for COSP) - - real(r8) :: ice_lw_abs (nlwbands,pcols,pver) ! ice absorption optics depth (LW) - real(r8) :: liq_lw_abs (nlwbands,pcols,pver) ! liquid absorption optics depth (LW) - real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) - real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) - real(r8) :: grau_lw_abs (nlwbands,pcols,pver)! graupel absorption optics depth (LW) - real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) - - ! Aerosol radiative properties **N.B.** These are zero-indexed to accomodate an "extra layer". - ! If no extra layer then the 0 index is ignored. - real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + ! in-cloud optical depths for COSP + real(r8) :: cld_tau_cloudsim(pcols,pver) ! liq + ice + real(r8) :: snow_tau_cloudsim(pcols,pver) ! snow + real(r8) :: grau_tau_cloudsim(pcols,pver) ! graupel + real(r8) :: cld_lw_abs_cloudsim(pcols,pver) ! liq + ice + real(r8) :: snow_lw_abs_cloudsim(pcols,pver)! snow + real(r8) :: grau_lw_abs_cloudsim(pcols,pver)! graupel ! Set vertical indexing in RRTMGP to be the same as CAM (top to bottom). logical, parameter :: top_at_1 = .true. - ! RRTMGP cloud objects (McICA sampling of cloud optical properties) - type(ty_optical_props_1scl) :: cloud_lw - type(ty_optical_props_2str) :: cloud_sw + ! TOA solar flux on RRTMGP g-points + real(r8), allocatable :: toa_flux(:,:) + ! TSI from RRTMGP data (from sum over g-point representation) + real(r8) :: tsi_ref + + ! Planck sources for LW. + type(ty_source_func_lw) :: sources_lw - ! gas vmr. Separate objects because SW only does calculations for daylight columns. + ! Gas volume mixing ratios. Use separate objects for LW and SW because SW only does + ! calculations for daylight columns. + ! These objects have a final method which deallocates the internal memory when they + ! go out of scope (i.e., when radiation_tend returns), so no need for explicit deallocation. type(ty_gas_concs) :: gas_concs_lw type(ty_gas_concs) :: gas_concs_sw - ! Atmosphere optics. This object contains gas optics, aerosol optics, and cloud optics. -! type(ty_optical_props_1scl) :: gas_optics_lw + ! Atmosphere optics. This object is initialized with gas optics, then is incremented + ! by the aerosol optics for the clear-sky radiative flux calculations, and then + ! incremented again by the cloud optics for the all-sky radiative flux calculations. + type(ty_optical_props_1scl) :: atm_optics_lw type(ty_optical_props_2str) :: atm_optics_sw - ! aerosol optics + ! Cloud optical properties objects (McICA sampling of cloud optical properties). + type(ty_optical_props_1scl) :: cloud_lw + type(ty_optical_props_2str) :: cloud_sw + + ! Aerosol optical properties objects. type(ty_optical_props_1scl) :: aer_lw type(ty_optical_props_2str) :: aer_sw @@ -1013,11 +1011,6 @@ subroutine radiation_tend( & real(r8) :: fnl(pcols,pverp) ! net longwave flux real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux - ! TOA solar flux on RRTMGP g-points - real(r8), allocatable :: toa_flux(:,:) - ! TSI from RRTMGP data (from sum over g-point representation) - real(r8) :: tsi_ref - ! for COSP real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau @@ -1126,7 +1119,6 @@ subroutine radiation_tend( & end do end if - ! Find tropopause height if needed for diagnostic output if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, & @@ -1137,18 +1129,6 @@ subroutine radiation_tend( & ! calculated by each surface model at this time nextsw_cday = radiation_nextsw_cday() - - ! if Nday = 0, then we should not do shortwave, - ! *but* at then end of subroutine, heating rates will still be calculated, - ! and would get whatever is in pbuf for qrl / qrs. - ! To avoid non-daylit columns - ! from having shortwave heating, we should reset here: -! if (nday == 0) then -! qrs(1:ncol,1:pver) = 0._r8 -! rd%qrsc(1:ncol,1:pver) = 0._r8 ! this is what gets turned into QRSC in output (probably not needed here.) -! dosw = .false. -! end if - if (dosw .or. dolw) then allocate( & @@ -1199,13 +1179,15 @@ subroutine radiation_tend( & call endrun(sub//': ERROR: gas_concs_sw%init: '//trim(errmsg)) end if - ! Init and allocate arrays in atm optics object. + ! Initialize object for combined gas + aerosol + cloud optics. + ! Allocates arrays for properties represented on g-points. errmsg = atm_optics_sw%alloc_2str(nday, nlay, kdist_sw) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: gas_optics_sw%alloc_2str: '//trim(errmsg)) end if - ! Init and allocate arrays in aerosol optics object. + ! Initialize object for SW aerosol optics. Allocates arrays + ! for properties represented by band. errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber()) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: aer_sw%alloc_2str: '//trim(errmsg)) @@ -1281,7 +1263,7 @@ subroutine radiation_tend( & call set_sw_diags() if (write_output) then - call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) ! QRS = qrs/cpair; whatever qrs is in pbuf + call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) end if end if ! (active_calls(icall)) @@ -1299,64 +1281,34 @@ subroutine radiation_tend( & if (dolw) then - call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) - - call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) - - cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) - - - if (cldfsnow_idx > 0) then - ! add in snow - call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) - do i = 1, ncol - do k = 1, pver - if (cldfprime(i,k) > 0._r8) then - c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & - + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) - else - c_cld_lw_abs(:,i,k) = 0._r8 - end if - end do - end do - else - c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) + ! Initialize object for Planck sources. + errmsg = sources_lw%alloc(ncol, nlay, kdist_lw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR, sources_lw%alloc: '//trim(errmsg)) end if - if (cldfgrau_idx > 0 .and. graupel_in_rad) then - ! add in graupel - call grau_cloud_get_rad_props_lw(state, pbuf, grau_lw_abs) - do i = 1, ncol - do k = 1, pver - if (cldfprime(i,k) > 0._r8) then - c_cld_lw_abs(:,i,k) = ( cldfgrau(i,k)*grau_lw_abs(:,i,k) & - + cld(i,k)*c_cld_lw_abs(:,i,k) )/cldfprime(i,k) - else - c_cld_lw_abs(:,i,k) = 0._r8 - end if - end do - end do + ! Set cloud optical properties in cloud_lw object. + call rrtmgp_set_cloud_lw( & + state, pbuf, nlay, cld, cldfsnow, & + cldfgrau, cldfprime, graupel_in_rad, kdist_lw, cloud_lw, & + cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, grau_lw_abs_cloudsim ) + + ! Initialize object for gas concentrations + errmsg = gas_concs_lw%init(gaslist_lc) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR, gas_concs_lw%init: '//trim(errmsg)) end if - ! cloud_lw : cloud optical properties. - call initialize_rrtmgp_cloud_optics_lw(ncol, nlay, kdist_lw, cloud_lw) - - call rrtmgp_set_cloud_lw(state, nlwbands, cldfprime, c_cld_lw_abs, kdist_lw, & - cloud_lw) - - ! initialize/allocate object for aerosol optics - errmsg = aer_lw%alloc_1scl(ncol, & - nlay, & - kdist_lw%get_band_lims_wavenumber(), & - name='longwave aerosol optics') + ! Initialize object for combined gas + aerosol + cloud optics. + errmsg = atm_optics_lw%alloc_1scl(ncol, nlay, kdist_lw) if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: aer_lw%alloc_1scalar: '//trim(errmsg)) + call endrun(sub//': ERROR: gas_optics_lw%alloc_1scl: '//trim(errmsg)) end if - ! initialize object for gas concentrations - errmsg = gas_concs_lw%init(gaslist_lc) + ! Initialize object for LW aerosol optics. + errmsg = aer_lw%alloc_1scl(ncol, nlay, kdist_lw%get_band_lims_wavenumber()) if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR, gas_concs_lw%init: '//trim(errmsg)) + call endrun(sub//': ERROR: aer_lw%alloc_1scl: '//trim(errmsg)) end if ! The climate (icall==0) calculation must occur last. @@ -1364,53 +1316,50 @@ subroutine radiation_tend( & if (active_calls(icall)) then + ! Set gas volume mixing ratios for this call in gas_concs_lw. call rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs_lw) - call aer_rad_props_lw( & ! get absorption optical depth - icall, & ! input - state, & ! input - pbuf, & ! input - aer_lw_abs & ! outut - ) - call rrtmgp_set_aer_lw( & ! put absorption optical depth into aer_lw - ncol, & ! input - nlwbands, & ! input - aer_lw_abs, & ! input - aer_lw & ! output, %tau, ordered bottom-to-top - ) + ! Compute the gas optics and Planck sources. + errmsg = kdist_lw%gas_optics( & + pmid_rad, pint_rad, t_rad, t_sfc, gas_concs_lw, & + atm_optics_lw, sources_lw) + + ! Set LW aerosol optical properties in the aer_lw object. + call rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw) - ! check that optical properties are in bounds: - call clipper(cloud_lw%tau, 0._r8, huge(cloud_lw%tau)) - call clipper(aer_lw%tau, 0._r8, huge(aer_lw%tau)) - - ! Compute LW fluxes - errmsg = rte_lw(kdist_lw, & ! input - gas_concs_lw, & ! input, (rrtmgp_set_gases_lw) - pmid_rad, & ! input, (rrtmgp_set_state) - t_rad, & ! input, (rrtmgp_set_state) - pint_rad, & ! input, (rrtmgp_set_state) - t_sfc, & ! input (rrtmgp_set_state) - emis_sfc, & ! input (rrtmgp_set_state) - cloud_lw, & ! input, (rrtmgp_set_cloud_lw) - flw, & ! output - flwc, & ! output - aer_props=aer_lw & ! optional input, (rrtmgp_set_aer_lw) - ) ! note inc_flux is an optional input, but as defined in set_rrtmgp_state, it is only for shortwave + ! Increment the gas optics by the aerosol optics. + errmsg = aer_lw%increment(atm_optics_lw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR in aer_lw%increment: '//trim(errmsg)) + end if + + ! Compute clear-sky LW fluxes + errmsg = rte_lw(atm_optics_lw, top_at_1, sources_lw, emis_sfc, flwc) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR in clear-sky rte_lw: '//trim(errmsg)) + end if + + ! Increment the gas+aerosol optics by the cloud optics. + errmsg = cloud_lw%increment(atm_optics_lw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR in cloud_lw%increment: '//trim(errmsg)) + end if + + ! Compute all-sky LW fluxes + errmsg = rte_lw(atm_optics_lw, top_at_1, sources_lw, emis_sfc, flw) if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: rte_lw: '//trim(errmsg)) + call endrun(sub//': ERROR in all-sky rte_lw: '//trim(errmsg)) end if - ! - ! -- longwave output -- - ! - call set_lw_diags() ! Reverse direction of LW fluxes back to TOP-to-BOTTOM - ! And derive LW dry static energy tendency (QRL, rd%QRLC (J/kg/s)) + + ! Transform RRTMGP outputs to CAM outputs and compute heating rates. + call set_lw_diags() + if (write_output) then - ! QRL retrieved from pbuf and divided by cpair [(J/(kg s)) / (J/(K kg)) = K/s] call radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out) end if - end if - end do + end if ! (active_calls(icall)) + end do ! loop over diagnostic calcs (icall) else if (conserve_energy) then @@ -1430,7 +1379,7 @@ subroutine radiation_tend( & if (docosp) then emis(:,:) = 0._r8 - emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(idx_lw_cloudsim,:ncol,:)) + emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs_cloudsim(:ncol,:)) call outfld('EMIS', emis, pcols, lchnk) ! compute grid-box mean SW and LW snow optical depth for use by COSP @@ -1445,11 +1394,11 @@ subroutine radiation_tend( & if (cldfgrau_idx > 0 .and. graupel_in_rad) then gb_snow_tau(i,k) = snow_tau_cloudsim(i,k)*cldfsnow(i,k) + & grau_tau_cloudsim(i,k)*cldfgrau(i,k) - gb_snow_lw(i,k) = snow_lw_abs(idx_lw_cloudsim,i,k)*cldfsnow(i,k) + & - grau_lw_abs(idx_lw_cloudsim,i,k)*cldfgrau(i,k) + gb_snow_lw(i,k) = snow_lw_abs_cloudsim(i,k)*cldfsnow(i,k) + & + grau_lw_abs_cloudsim(i,k)*cldfgrau(i,k) else gb_snow_tau(i,k) = snow_tau_cloudsim(i,k)*cldfsnow(i,k) - gb_snow_lw(i,k) = snow_lw_abs(idx_lw_cloudsim,i,k)*cldfsnow(i,k) + gb_snow_lw(i,k) = snow_lw_abs_cloudsim(i,k)*cldfsnow(i,k) end if end if end do @@ -1471,16 +1420,11 @@ subroutine radiation_tend( & end if end if ! docosp - else ! --> radiative flux calculations not updated - ! convert radiative heating rates from Q*dp to Q for energy conservation - ! qrs and qrl are whatever are in pbuf - ! since those might have been multiplied by pdel, we actually need to divide by pdel - ! to get back to what we want, which is a DSE tendency. - ! ** if you change qrs and qrl from J/kg/s here, then it won't be a DSE tendency, - ! yet it is expected to be in radheat_tend to get ptend%s - ! Does not matter if qrs and qrl are zero on these time steps - - ! this completes the conserve_energy logic, since neither sw nor lw ran + else + ! When radiative flux calculations not done, the quantity Q*dp from the previous + ! timestep is retrieved from the physics buffer and used for this timestep. + ! It is first converted to Q (dry static energy tendency) before being passed + ! to radheat_tend. if (conserve_energy) then qrs(1:ncol,1:pver) = qrs(1:ncol,1:pver) / state%pdel(1:ncol,1:pver) qrl(1:ncol,1:pver) = qrl(1:ncol,1:pver) / state%pdel(1:ncol,1:pver) @@ -1488,19 +1432,12 @@ subroutine radiation_tend( & end if ! if (dosw .or. dolw) then - ! ------------------------------------------------------------------------ - ! - ! After any radiative transfer is done: output & convert fluxes to heating - ! - - call rad_data_write(pbuf, state, cam_in, coszrs) ! output rad inputs and resulting heating rates - - ! NET RADIATIVE HEATING TENDENCY - ! INPUT: state, qrl, qrs, fsns, fsnt, flns, flnt, asdir - ! OUTPUT: - ! ptend%s = (qrs + qrl) - ! net_flx = fsnt - fsns - flnt + flns - ! pbuf is an argument, but *is not used* (qrl/qrs are pointers into it) + ! Output for PORT: Parallel Offline Radiative Transport + call rad_data_write(pbuf, state, cam_in, coszrs) + + ! Compute net radiative heating tendency. Note that the WACCM version + ! of radheat_tend merges upper atmosphere heating rates with those calculated + ! by RRTMGP. call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & fsnt, flns, flnt, cam_in%asdir, net_flx) @@ -1514,8 +1451,8 @@ subroutine radiation_tend( & call outfld('HR', ftem, pcols, lchnk) end if - ! convert radiative heating rates to Q*dp for energy conservation - ! QRS & QRL should be in J/(kg s) (dry static energy tendency); not sure where this goes after radiation. + ! The radiative heating rates are carried in the physics buffer across timesteps + ! as Q*dp (for energy conservation). if (conserve_energy) then qrs(1:ncol,1:pver) = qrs(1:ncol,1:pver) * state%pdel(1:ncol,1:pver) qrl(1:ncol,1:pver) = qrl(1:ncol,1:pver) * state%pdel(1:ncol,1:pver) @@ -1532,6 +1469,7 @@ subroutine radiation_tend( & call free_fluxes(fsw) call free_fluxes(fswc) + call sources_lw%finalize() call free_optics_lw(cloud_lw) call free_optics_lw(aer_lw) call free_fluxes(flw) @@ -1585,8 +1523,8 @@ subroutine set_sw_diags() fsds(idxday(i)) = fsw%flux_dn(i, nlay+1) rd%fsdsc(idxday(i)) = fswc%flux_dn(i, nlay+1) rd%fsutoa(idxday(i)) = fsw%flux_up(i, 1) - rd%fsntoa(idxday(i)) = fsw%flux_net(i, 1) ! net sw flux at TOA (*NOT* the same as fsnt) - rd%fsntoac(idxday(i)) = fswc%flux_net(i, 1) ! net sw clearsky flux at TOA (*NOT* the same as fsntc) + rd%fsntoa(idxday(i)) = fsw%flux_net(i, 1) + rd%fsntoac(idxday(i)) = fswc%flux_net(i, 1) rd%solin(idxday(i)) = fswc%flux_dn(i, 1) rd%flux_sw_up(idxday(i),ktopcam:) = fsw%flux_up(i,ktoprad:) rd%flux_sw_dn(idxday(i),ktopcam:) = fsw%flux_dn(i,ktoprad:) @@ -1789,6 +1727,7 @@ subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) + ! QRS is output as temperature tendency. call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) @@ -2556,27 +2495,6 @@ end subroutine reset_fluxes !========================================================================================= -subroutine initialize_rrtmgp_cloud_optics_lw(ncol, nlevels, kdist, optics) - - integer, intent(in) :: ncol, nlevels - type(ty_gas_optics_rrtmgp), intent(in) :: kdist - type(ty_optical_props_1scl), intent(out) :: optics - - integer :: ngpt - character(len=128) :: errmsg - character(len=128) :: sub = 'initialize_rrtmgp_cloud_optics_lw' - - ngpt = kdist%get_ngpt() - errmsg =optics%alloc_1scl(ncol, nlevels, kdist, name='longwave cloud optics') - if (len_trim(errmsg) > 0) then - call endrun(trim(sub)//': ERROR: optics%alloc_1scalar: '//trim(errmsg)) - end if - optics%tau(:ncol, :nlevels, :ngpt) = 0.0 - -end subroutine initialize_rrtmgp_cloud_optics_lw - -!========================================================================================= - subroutine free_optics_sw(optics) type(ty_optical_props_2str), intent(inout) :: optics @@ -2585,6 +2503,7 @@ subroutine free_optics_sw(optics) if (allocated(optics%ssa)) deallocate(optics%ssa) if (allocated(optics%g)) deallocate(optics%g) call optics%finalize() + end subroutine free_optics_sw !========================================================================================= @@ -2595,6 +2514,7 @@ subroutine free_optics_lw(optics) if (allocated(optics%tau)) deallocate(optics%tau) call optics%finalize() + end subroutine free_optics_lw !========================================================================================= @@ -2611,6 +2531,7 @@ subroutine free_fluxes(fluxes) if (associated(fluxes%bnd_flux_dn)) deallocate(fluxes%bnd_flux_dn) if (associated(fluxes%bnd_flux_net)) deallocate(fluxes%bnd_flux_net) if (associated(fluxes%bnd_flux_dn_dir)) deallocate(fluxes%bnd_flux_dn_dir) + end subroutine free_fluxes !========================================================================================= diff --git a/src/physics/rrtmgp/rrtmgp_driver.F90 b/src/physics/rrtmgp/rrtmgp_driver.F90 deleted file mode 100644 index c7e0ed5324..0000000000 --- a/src/physics/rrtmgp/rrtmgp_driver.F90 +++ /dev/null @@ -1,382 +0,0 @@ -! This code is based closely on mo_rrtmgp_clr_all_sky.F90 from -! RRTM for GCM Applications - Parallel (RRTMGP) -! -! Eli Mlawer and Robert Pincus -! Andre Wehe and Jennifer Delamere -! email: rrtmgp@aer.com -! -! Copyright 2017, Atmospheric and Environmental Research and -! Regents of the University of Colorado. All right reserved. -! -! Use and duplication is permitted under the terms of the -! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause -! - -! -! This module provides an interface to RRTMGP for a common use case -- -! users want to start from gas concentrations, pressures, and temperatures, -! and compute clear-sky (aerosol plus gases) and all-sky fluxes. -! The routines here have the same names as those in mo_rrtmgp_[ls]w; normally users -! will use either this module or the underling modules, but not both -! -module rrtmgp_driver - use mo_rte_kind, only: wp - ! use mo_gas_optics, only: ty_gas_optics ! replacing this with _rrtmgp version - - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - - use mo_gas_concentrations, only: ty_gas_concs - use mo_optical_props, only: ty_optical_props, & - ty_optical_props_arry, & - ty_optical_props_1scl, & - ty_optical_props_2str, & - ty_optical_props_nstr - use mo_source_functions, only: ty_source_func_lw - ! use mo_fluxes, only: ty_fluxes ! not needed b/c mo_fluxes_byband extends this type - use mo_fluxes_byband, only: ty_fluxes_byband - use mo_rte_lw, only: base_rte_lw => rte_lw - use mo_rte_sw, only: base_rte_sw => rte_sw - - use cam_logfile, only: iulog - - implicit none - - public :: rte_lw, rte_sw - -contains - ! -------------------------------------------------- - ! - ! Interfaces using clear (gas + aerosol) and all-sky categories, starting from - ! pressures, temperatures, and gas amounts for the gas contribution - ! - ! -------------------------------------------------- - function rte_lw(k_dist, gas_concs, p_lay, t_lay, p_lev, & - t_sfc, sfc_emis, cloud_props, & - allsky_fluxes, clrsky_fluxes, & - aer_props, col_dry, t_lev, inc_flux, n_gauss_angles) result(error_msg) - ! class(ty_gas_optics), intent(in ) :: k_dist !< derived type with spectral information - class(ty_gas_optics_rrtmgp), intent(in ) :: k_dist !< derived type with spectral information - - type(ty_gas_concs), intent(in ) :: gas_concs !< derived type encapsulating gas concentrations - real(wp), dimension(:,:), intent(in ) :: p_lay, t_lay !< pressure [Pa], temperature [K] at layer centers (ncol,nlay) - real(wp), dimension(:,:), intent(in ) :: p_lev !< pressure at levels/interfaces [Pa] (ncol,nlay+1) - real(wp), dimension(:), intent(in ) :: t_sfc !< surface temperature [K] (ncol) - real(wp), dimension(:,:), intent(in ) :: sfc_emis !< emissivity at surface [] (nband, ncol) - class(ty_optical_props_arry), intent(in ) :: cloud_props !< cloud optical properties (ncol,nlay,ngpt) - class(ty_fluxes_byband), intent(inout) :: allsky_fluxes, clrsky_fluxes ! 3/21 - _byband bpm - - ! Optional inputs - class(ty_optical_props_arry), & - optional, intent(in ) :: aer_props !< aerosol optical properties - real(wp), dimension(:,:), & - optional, intent(in ) :: col_dry !< Molecular number density (ncol, nlay) - real(wp), dimension(:,:), target, & - optional, intent(in ) :: t_lev !< temperature at levels [K] (ncol, nlay+1) - real(wp), dimension(:,:), target, & - optional, intent(in ) :: inc_flux !< incident flux at domain top [W/m2] (ncol, ngpts) - integer, optional, intent(in ) :: n_gauss_angles ! Number of angles used in Gaussian quadrature (no-scattering solution) - character(len=128) :: error_msg - ! -------------------------------- - ! Local variables - ! - class(ty_optical_props_arry), allocatable :: optical_props - type(ty_source_func_lw) :: sources - - integer :: ncol, nlay, ngpt, nband, nstr - logical :: top_at_1 - ! -------------------------------- - ! Problem sizes - ! - - error_msg = "" - - ncol = size(p_lay, 1) - nlay = size(p_lay, 2) - ngpt = k_dist%get_ngpt() - nband = k_dist%get_nband() - - top_at_1 = p_lay(1, 1) < p_lay(1, nlay) - - ! ------------------------------------------------------------------------------------ - ! Error checking - ! - if(present(aer_props)) then - if(any([aer_props%get_ncol(), & - aer_props%get_nlay()] /= [ncol, nlay])) & - error_msg = "rrtmpg_lw: aerosol properties inconsistently sized" - if(.not. any(aer_props%get_ngpt() /= [ngpt, nband])) & - error_msg = "rrtmpg_lw: aerosol properties inconsistently sized" - end if - - if(present(t_lev)) then - if(any([size(t_lev, 1), & - size(t_lev, 2)] /= [ncol, nlay+1])) & - error_msg = "rrtmpg_lw: t_lev inconsistently sized" - end if - - if(present(inc_flux)) then - if(any([size(inc_flux, 1), & - size(inc_flux, 2)] /= [ncol, ngpt])) & - error_msg = "rrtmpg_lw: incident flux inconsistently sized" - end if - if(len_trim(error_msg) > 0) return - - ! ------------------------------------------------------------------------------------ - ! Optical properties arrays - ! - select type(cloud_props) - class is (ty_optical_props_1scl) ! No scattering - allocate(ty_optical_props_1scl::optical_props) - class is (ty_optical_props_2str) - allocate(ty_optical_props_2str::optical_props) - class is (ty_optical_props_nstr) - allocate(ty_optical_props_nstr::optical_props) - nstr = size(cloud_props%tau,1) - end select - - error_msg = optical_props%init(k_dist) - - if(len_trim(error_msg) > 0) return - select type (optical_props) - class is (ty_optical_props_1scl) ! No scattering - error_msg = optical_props%alloc_1scl(ncol, nlay) - class is (ty_optical_props_2str) - error_msg = optical_props%alloc_2str(ncol, nlay) - class is (ty_optical_props_nstr) - error_msg = optical_props%alloc_nstr(nstr, ncol, nlay) - end select - if (error_msg /= '') return - - ! - ! Source function - ! - error_msg = sources%init(k_dist) - error_msg = sources%alloc(ncol, nlay) - if (error_msg /= '') return - - ! ------------------------------------------------------------------------------------ - ! Clear skies - ! - ! Gas optical depth -- pressure need to be expressed as Pa - ! - error_msg = k_dist%gas_optics(p_lay, p_lev, t_lay, t_sfc, gas_concs, & - optical_props, sources) !, & - ! col_dry, t_lev) - ! col_dry & t_lev are optional, and we have not provided them. - if (error_msg /= '') then - return - end if - - ! ---------------------------------------------------- - ! Clear sky is gases + aerosols (if they're supplied) - ! - if (present(aer_props)) then - error_msg = aer_props%increment(optical_props) - end if - if (error_msg /= '') then - return - end if - - error_msg = base_rte_lw(optical_props, top_at_1, sources, & - sfc_emis, clrsky_fluxes, & - inc_flux, n_gauss_angles) - if (error_msg /= '') then - return - end if - - ! ------------------------------------------------------------------------------------ - ! All-sky fluxes = clear skies + clouds - ! - error_msg = cloud_props%increment(optical_props) - if(error_msg /= '') return - - error_msg = base_rte_lw(optical_props, top_at_1, sources, & - sfc_emis, allsky_fluxes, & - inc_flux, n_gauss_angles) - - call sources%finalize() - call optical_props%finalize() - - end function rte_lw - ! -------------------------------------------------- - ! -------------------------------------------------- - ! -------------------------------------------------- - function rte_sw(k_dist, & - gas_concs, & - p_lay, & - t_lay, & - p_lev, & - mu0, & - sfc_alb_dir, & - sfc_alb_dif, & - cloud_props, & - allsky_fluxes, & - clrsky_fluxes, & - aer_props, & - col_dry, & - inc_flux, & !< optional input: total solar irradiance (ncol, ngpt) - tsi_scaling, & !< optional input: scalar scaling factor for TSI - tsi_scaling_gpt & !< optional input: scaling for TSI by gpt - ) result(error_msg) - class(ty_gas_optics_rrtmgp), intent(in ) :: k_dist !< derived type with spectral information - - type(ty_gas_concs), intent(in ) :: gas_concs !< derived type encapsulating gas concentrations - real(wp), dimension(:,:), intent(in ) :: p_lay, t_lay !< pressure [Pa], temperature [K] at layer centers (ncol,nlay) - real(wp), dimension(:,:), intent(in ) :: p_lev !< pressure at levels/interfaces [Pa] (ncol,nlay+1) - real(wp), dimension(: ), intent(in ) :: mu0 !< cosine of solar zenith angle - real(wp), dimension(:,:), intent(in ) :: sfc_alb_dir, sfc_alb_dif - ! surface albedo for direct and diffuse radiation (band, col) - class(ty_optical_props_arry), intent(in ) :: cloud_props !< cloud optical properties (ncol,nlay,ngpt) - class(ty_fluxes_byband), intent(inout) :: allsky_fluxes, clrsky_fluxes - - ! Optional inputs - class(ty_optical_props_arry), target, & - optional, intent(in ) :: aer_props !< aerosol optical properties - real(wp), dimension(:,:), & - optional, intent(in ) :: col_dry, & !< Molecular number density (ncol, nlay) - inc_flux !< incident flux at domain top [W/m2] (ncol, ngpts) - real(wp), optional, intent(in ) :: tsi_scaling !< Optional scaling for total solar irradiance (SCALAR) - real(wp), dimension(:), optional, intent(in ) :: tsi_scaling_gpt !< Optional scaling of solar irradiance by gpoint - - - character(len=128) :: error_msg - ! -------------------------------- - ! Local variables - ! - class(ty_optical_props_arry), allocatable :: optical_props - real(wp), dimension(:,:), allocatable :: toa_flux - integer :: ncol, nlay, ngpt, nband, nstr - integer :: icol - logical :: top_at_1 - ! -------------------------------- - ! Problem sizes - ! - - error_msg = "" - - ncol = size(p_lay, 1) - nlay = size(p_lay, 2) - ngpt = k_dist%get_ngpt() - nband = k_dist%get_nband() - - top_at_1 = p_lay(1, 1) < p_lay(1, nlay) - - ! ------------------------------------------------------------------------------------ - ! Error checking - ! - if(present(aer_props)) then - if(any([aer_props%get_ncol(), & - aer_props%get_nlay()] /= [ncol, nlay])) & - error_msg = "rrtmgp_driver rte_sw: aerosol properties inconsistently sized" - if(.not. any(aer_props%get_ngpt() /= [ngpt, nband])) & - error_msg = "rrtmgp_driver rte_sw: aerosol properties inconsistently sized" - end if - - if (present(tsi_scaling) .and. (present(tsi_scaling_gpt))) then - error_msg = "rrtmgp_driver rte_sw: Only one of [tsi_scaling, tsi_scaling_gpt] may be specified." - end if - - if(present(tsi_scaling)) then - if(tsi_scaling <= 0._wp) then - error_msg = "rrtmgp_driver rte_sw: tsi_scaling is < 0" - end if - end if - - if(present(inc_flux)) then - if(any([size(inc_flux, 1), size(inc_flux, 2)] /= [ncol, ngpt])) then - error_msg = "rrtmgp_driver rte_sw: incident flux inconsistently sized" - end if - end if - if(len_trim(error_msg) > 0) return - - ! ------------------------------------------------------------------------------------ - ! - ! Optical properties arrays - ! - select type(cloud_props) - class is (ty_optical_props_1scl) ! No scattering - allocate(ty_optical_props_1scl::optical_props) - class is (ty_optical_props_2str) - allocate(ty_optical_props_2str::optical_props) - class is (ty_optical_props_nstr) - allocate(ty_optical_props_nstr::optical_props) - nstr = cloud_props%get_nmom() - end select - - error_msg = optical_props%init(k_dist%get_band_lims_wavenumber(), & - k_dist%get_band_lims_gpoint()) - if(len_trim(error_msg) > 0) return - select type (optical_props) - class is (ty_optical_props_1scl) ! No scattering - error_msg = optical_props%alloc_1scl(ncol, nlay) - class is (ty_optical_props_2str) - error_msg = optical_props%alloc_2str(ncol, nlay) - class is (ty_optical_props_nstr) - error_msg = optical_props%alloc_nstr(nstr, ncol, nlay) - end select - if (error_msg /= '') return - - allocate(toa_flux(ncol, ngpt)) - ! ------------------------------------------------------------------------------------ - ! Clear skies - ! - ! Gas optical depth -- pressure need to be expressed as Pa - ! - error_msg = k_dist%gas_optics(p_lay, p_lev, t_lay, gas_concs, & - optical_props, toa_flux) ! , & - ! col_dry) - ! col_dry is optional and we have not provided it. - if (error_msg /= '') return - ! - ! If users have supplied an incident flux, use that - ! - if (present(inc_flux)) then - toa_flux(:,:) = inc_flux(:,:) - end if - ! - ! If there is a scaling provided, apply it - ! - if(present(tsi_scaling)) toa_flux(:,:) = toa_flux(:,:) * tsi_scaling - - if(present(tsi_scaling_gpt)) then - do icol = 1,ncol - toa_flux(icol,:) = toa_flux(icol,:) * tsi_scaling_gpt - end do - end if - ! ---------------------------------------------------- - ! Clear sky is gases + aerosols (if they're supplied) - ! - if(present(aer_props)) error_msg = aer_props%increment(optical_props) - if(error_msg /= '') return - - error_msg = base_rte_sw(optical_props, top_at_1, & - mu0, toa_flux, & - sfc_alb_dir, sfc_alb_dif, & - clrsky_fluxes) - - if(error_msg /= '') return - ! ------------------------------------------------------------------------------------ - ! All-sky fluxes = clear skies + clouds - ! - error_msg = cloud_props%increment(optical_props) - if (error_msg /= '') then - return - end if - - error_msg = base_rte_sw(optical_props, & ! (in) Optical properties provided as arrays - top_at_1, & ! (in) Is the top of the domain at index 1? - mu0, & ! (in) cosine of solar zenith angle (ncol) - toa_flux, & ! (in) incident flux at top of domain [W/m2] (ncol, ngpt) - sfc_alb_dir, & ! (in) surface albedo, direct (nband, ncol) - sfc_alb_dif, & ! (in) surface albedo, diffuse (nband, ncol) - allsky_fluxes & ! (inout) Class describing output calculations (ty_fluxes_byband) - ) - - - call optical_props%finalize() - if (allocated(toa_flux)) then - deallocate(toa_flux) - end if - end function rte_sw - -end module rrtmgp_driver diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index fc6c5d4c4e..e629950c64 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -17,9 +17,9 @@ module rrtmgp_inputs use physics_buffer, only: physics_buffer_desc use camsrfexch, only: cam_in_t -use radconstants, only: nswbands, nlwbands, nswgpts, get_sw_spectral_boundaries, & - idx_sw_diag, idx_sw_cloudsim -use radconstants, only: nradgas, gaslist +use radconstants, only: nradgas, gaslist, nswbands, nlwbands, nswgpts, nlwgpts, & + get_sw_spectral_boundaries, idx_sw_diag, idx_sw_cloudsim, & + idx_lw_cloudsim use rad_constituents, only: rad_cnst_get_gas @@ -302,7 +302,8 @@ end function get_molar_mass_ratio subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, gas_concs, idxday) - ! Set volume mixing ratio in gas_concs data structure. + ! Set volume mixing ratio in gas_concs object. + ! The gas_concs%set_vmr method copies data into internally allocated storage. integer, intent(in) :: icall ! index of climate/diagnostic radiation call character(len=*), intent(in) :: gas_name @@ -466,57 +467,145 @@ end subroutine rrtmgp_set_gases_sw !================================================================================================== -subroutine rrtmgp_set_cloud_lw(state, nlwbands, cldfrac, c_cld_lw_abs, lwkDist, cloud_lw) +subroutine rrtmgp_set_cloud_lw( & + state, pbuf, nlay, cld, cldfsnow, & + cldfgrau, cldfprime, graupel_in_rad, kdist_lw, cloud_lw, & + cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, grau_lw_abs_cloudsim ) + ! Compute combined cloud optical properties. ! Create MCICA stochastic arrays for cloud LW optical properties. + ! Initialize optical properties object (cloud_lw) and load with MCICA columns. ! arguments - type(physics_state), intent(in) :: state - integer, intent(in) :: nlwbands - real(r8), intent(in) :: cldfrac(pcols,pver) ! combined cloud fraction (snow plus regular) - real(r8), intent(in) :: c_cld_lw_abs(nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) - class(ty_gas_optics_rrtmgp), intent(in) :: lwkDist - type(ty_optical_props_1scl), intent(inout) :: cloud_lw - ! local vars - integer :: i - integer :: ncol - integer :: ngptlw - real(r8), allocatable :: taucmcl(:,:,:) ! cloud optical depth [mcica] - character(len=32) :: sub = 'rrtmgp_set_cloud_lw' + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: nlay ! number of layers in radiation calculation (may include "extra layer") + real(r8), pointer :: cld(:,:) ! cloud fraction (liq+ice) + real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds" + real(r8), pointer :: cldfgrau(:,:) ! cloud fraction of just "graupel clouds" + real(r8), intent(in) :: cldfprime(pcols,pver) ! combined cloud fraction + + logical, intent(in) :: graupel_in_rad ! use graupel in radiation code + class(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw + type(ty_optical_props_1scl), intent(out) :: cloud_lw + + ! Diagnostic outputs + real(r8), intent(out) :: cld_lw_abs_cloudsim(pcols,pver) ! in-cloud snow optical depth (for COSP) + real(r8), intent(out) :: snow_lw_abs_cloudsim(pcols,pver)! in-cloud snow optical depth (for COSP) + real(r8), intent(out) :: grau_lw_abs_cloudsim(pcols,pver)! in-cloud Graupel optical depth (for COSP) + + ! Local variables + + integer :: i, k, ncol + integer :: igpt, nver + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: liq_lw_abs(nlwbands,pcols,pver) ! liquid absorption optics depth (LW) + real(r8) :: ice_lw_abs(nlwbands,pcols,pver) ! ice absorption optics depth (LW) + real(r8) :: cld_lw_abs(nlwbands,pcols,pver) ! cloud absorption optics depth (LW) + real(r8) :: snow_lw_abs(nlwbands,pcols,pver) ! snow absorption optics depth (LW) + real(r8) :: grau_lw_abs(nlwbands,pcols,pver) ! graupel absorption optics depth (LW) + real(r8) :: c_cld_lw_abs(nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) + + ! Arrays for converting from CAM chunks to RRTMGP inputs. + real(r8), allocatable :: cldf(:,:) + real(r8), allocatable :: tauc(:,:,:) + real(r8), allocatable :: taucmcl(:,:,:) + character(len=128) :: errmsg + character(len=*), parameter :: sub = 'rrtmgp_set_cloud_lw' !-------------------------------------------------------------------------------- + ncol = state%ncol - ngptlw = lwkDist%get_ngpt() - allocate(taucmcl(ngptlw,ncol,pver)) + ! Combine the cloud optical properties. These calculations are done on CAM "chunks". + + ! gammadist liquid optics + call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) + ! Mitchell ice optics + call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) + + cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) + + if (associated(cldfsnow)) then + ! add in snow + call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0._r8) then + c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & + + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) + else + c_cld_lw_abs(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) + end if + + ! add in graupel + if (associated(cldfgrau) .and. graupel_in_rad) then + call grau_cloud_get_rad_props_lw(state, pbuf, grau_lw_abs) + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0._r8) then + c_cld_lw_abs(:,i,k) = ( cldfgrau(i,k)*grau_lw_abs(:,i,k) & + + cld(i,k)*c_cld_lw_abs(:,i,k) )/cldfprime(i,k) + else + c_cld_lw_abs(:,i,k) = 0._r8 + end if + end do + end do + end if + + ! Cloud optics for COSP + cld_lw_abs_cloudsim = cld_lw_abs(idx_lw_cloudsim,:,:) + snow_lw_abs_cloudsim = snow_lw_abs(idx_lw_cloudsim,:,:) + grau_lw_abs_cloudsim = grau_lw_abs(idx_lw_cloudsim,:,:) - !***NB*** this code is currently set up to create the subcols for all model layers - ! not just the ones where the radiation calc is being done. Need - ! to subset cldfrac and c_cld_lw_abs to avoid computing unneeded random numbers. + ! Extract just the layers of CAM where RRTMGP does calculations. + + ! number of CAM's layers in radiation calculation. Does not include the "extra layer". + nver = pver - ktopcam + 1 + + allocate( & + cldf(ncol,nver), & + tauc(nlwbands,ncol,nver), & + taucmcl(nlwgpts,ncol,nver) ) + + ! Subset "chunk" data so just the number of CAM layers in the + ! radiation calculation are used by MCICA to produce subcolumns. + cldf = cldfprime(:ncol, ktopcam:) + tauc = c_cld_lw_abs(:, :ncol, ktopcam:) call mcica_subcol_lw( & - lwkdist, & ! spectral information - nlwbands, & ! number of spectral bands - ngptlw, & ! number of subcolumns (g-point intervals) - ncol, & ! number of columns - ngptlw, & ! changeseed, should be set to number of subcolumns - state%pmid, & ! layer pressures (Pa) - cldfrac, & ! layer cloud fraction - c_cld_lw_abs, & ! cloud optical depth - taucmcl & ! OUTPUT: subcolumn cloud optical depth [mcica] (ngpt, ncol, nver) - ) + kdist_lw, nlwbands, nlwgpts, ncol, nver, & + nlwgpts, state%pmid, cldf, tauc, taucmcl ) + + errmsg =cloud_lw%alloc_1scl(ncol, nlay, kdist_lw) + if (len_trim(errmsg) > 0) then + call endrun(sub//': ERROR: cloud_lw%alloc_1scalar: '//trim(errmsg)) + end if ! If there is an extra layer in the radiation then this initialization ! will provide zero optical depths there. cloud_lw%tau = 0.0_r8 - do i = 1, ngptlw + + ! Set the properties on g-points. + do i = 1, nlwgpts cloud_lw%tau(:ncol, ktoprad:, i) = taucmcl(i, :ncol, ktopcam:) end do + + ! validate checks that: tau > 0 errmsg = cloud_lw%validate() if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: cloud_lw%validate: '//trim(errmsg)) end if - deallocate(taucmcl) + + ! All information is in cloud_lw, now deallocate local vars. + deallocate(cldf, tauc, taucmcl) + end subroutine rrtmgp_set_cloud_lw !================================================================================================== @@ -798,23 +887,38 @@ end subroutine rrtmgp_set_cloud_sw !================================================================================================== -subroutine rrtmgp_set_aer_lw(ncol, nlwbands, aer_lw_abs, aer_lw) +subroutine rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw) - ! Load aerosol optical properties into the RRTMGP object. + ! Load LW aerosol optical properties into the RRTMGP object. + + ! Arguments + integer, intent(in) :: icall + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) - ! arguments - integer, intent(in) :: ncol - integer, intent(in) :: nlwbands - real(r8), intent(in) :: aer_lw_abs(pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) type(ty_optical_props_1scl), intent(inout) :: aer_lw - character(len=32) :: sub = 'rrtmgp_set_aer_lw' - character(len=128) :: errmsg + ! Local variables + integer :: ncol + + ! Aerosol LW absorption optical depth + real(r8) :: aer_lw_abs (pcols,pver,nlwbands) + + character(len=*), parameter :: sub = 'rrtmgp_set_aer_lw' + character(len=128) :: errmsg !-------------------------------------------------------------------------------- + + ncol = state%ncol + + ! Get aerosol longwave optical properties. + call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) + ! If there is an extra layer in the radiation then this initialization ! will provide zero optical depths there. aer_lw%tau = 0.0_r8 + aer_lw%tau(:ncol, ktoprad:, :) = aer_lw_abs(:ncol, ktopcam:, :) + errmsg = aer_lw%validate() if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR: aer_lw%validate: '//trim(errmsg)) @@ -826,7 +930,7 @@ end subroutine rrtmgp_set_aer_lw subroutine rrtmgp_set_aer_sw( & icall, state, pbuf, nday, idxday, nnite, idxnite, aer_sw) - ! Load aerosol SW optical properties into the RRTMGP object. + ! Load SW aerosol optical properties into the RRTMGP object. ! Arguments integer, intent(in) :: icall From 49726ef7faba6cc63f255342855ac5732e5d79c7 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 28 Sep 2023 19:11:14 -0400 Subject: [PATCH 35/53] misc cleanup; restore putting Q*dp in pbuf for energy conservation --- src/physics/rrtmgp/radiation.F90 | 141 ++++++--------------------- src/physics/rrtmgp/rrtmgp_inputs.F90 | 9 +- 2 files changed, 32 insertions(+), 118 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 46f108d507..9d551dd4c6 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -21,15 +21,12 @@ module radiation use time_manager, only: get_nstep, is_first_step, is_first_restart_step, & get_curr_calday, get_step_size -use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, & - rad_cnst_get_gas, rad_cnst_out - +use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, rad_cnst_get_gas, rad_cnst_out use rrtmgp_inputs, only: rrtmgp_inputs_init -use radconstants, only: nswbands, nlwbands, nswgpts, & - nradgas, gasnamelength, gaslist, & - set_wavenumber_bands +use radconstants, only: nradgas, gasnamelength, gaslist, nswbands, nlwbands, & + nswgpts, set_wavenumber_bands use cloud_rad_props, only: cloud_rad_props_init @@ -218,12 +215,6 @@ module radiation type(ty_gas_optics_rrtmgp) :: kdist_sw type(ty_gas_optics_rrtmgp) :: kdist_lw -! Mapping from RRTMG shortwave bands to RRTMGP. Currently needed to continue using -! the SW optics datasets from RRTMG (even thought there is a slight mismatch in the -! band boundaries of the 2 bands that overlap with the LW bands). -integer, parameter, dimension(14) :: rrtmg_to_rrtmgp_swbands = & - [ 14, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13 ] - ! lower case version of gaslist for RRTMGP character(len=gasnamelength) :: gaslist_lc(nradgas) @@ -405,7 +396,6 @@ real(r8) function radiation_nextsw_cday() logical :: dosw ! true => do shosrtwave calc integer :: offset ! offset for calendar day calculation integer :: dtime ! integer timestep size - real(r8):: calday ! calendar day of real(r8):: caldayp1 ! calendar day of next time-step !----------------------------------------------------------------------- @@ -419,7 +409,7 @@ real(r8) function radiation_nextsw_cday() nstep = nstep + 1 offset = offset + dtime if (radiation_do('sw', nstep)) then - radiation_nextsw_cday = get_curr_calday(offset=offset) + radiation_nextsw_cday = get_curr_calday(offset=offset) dosw = .true. end if end do @@ -1022,9 +1012,6 @@ subroutine radiation_tend( & character(len=128) :: errmsg character(len=*), parameter :: sub = 'radiation_tend' - - logical :: conserve_energy = .false. ! Flag to carry (QRS,QRL)*dp across time steps. - !-------------------------------------------------------------------------------------- lchnk = state%lchnk @@ -1043,8 +1030,8 @@ subroutine radiation_tend( & write_output = .true. end if - dosw = radiation_do('sw', get_nstep()) ! do shortwave heating calc this timestep? - dolw = radiation_do('lw', get_nstep()) ! do longwave heating calc this timestep? + dosw = radiation_do('sw', get_nstep()) ! do shortwave radiation calc this timestep? + dolw = radiation_do('lw', get_nstep()) ! do longwave radiation calc this timestep? ! Cosine solar zenith angle for current time step calday = get_curr_calday() @@ -1167,7 +1154,7 @@ subroutine radiation_tend( & cld_tau_cloudsim, snow_tau_cloudsim, grau_tau_cloudsim ) if (write_output) then - call radiation_output_cld(lchnk, ncol, rd) + call radiation_output_cld(lchnk, rd) end if ! If no daylight columns, can't create empty RRTMGP objects @@ -1270,9 +1257,9 @@ subroutine radiation_tend( & end do ! loop over diagnostic calcs (icall) else - if (conserve_energy) then - qrs(1:ncol,1:pver) = qrs(1:ncol,1:pver) / state%pdel(1:ncol,1:pver) - end if + ! SW calc not done. pbuf carries Q*dp across timesteps. + ! Convert to Q before calling radheat_tend. + qrs(:ncol,:) = qrs(:ncol,:) / state%pdel(:ncol,:) end if ! if (dosw) !=======================! @@ -1362,9 +1349,9 @@ subroutine radiation_tend( & end do ! loop over diagnostic calcs (icall) else - if (conserve_energy) then - qrl(1:ncol,1:pver) = qrl(1:ncol,1:pver) / state%pdel(1:ncol,1:pver) - end if + ! LW calc not done. pbuf carries Q*dp across timesteps. + ! Convert to Q before calling radheat_tend. + qrl(:ncol,:) = qrl(:ncol,:) / state%pdel(:ncol,:) end if ! if (dolw) deallocate( & @@ -1421,14 +1408,11 @@ subroutine radiation_tend( & end if ! docosp else - ! When radiative flux calculations not done, the quantity Q*dp from the previous - ! timestep is retrieved from the physics buffer and used for this timestep. - ! It is first converted to Q (dry static energy tendency) before being passed - ! to radheat_tend. - if (conserve_energy) then - qrs(1:ncol,1:pver) = qrs(1:ncol,1:pver) / state%pdel(1:ncol,1:pver) - qrl(1:ncol,1:pver) = qrl(1:ncol,1:pver) / state%pdel(1:ncol,1:pver) - end if + ! Radiative flux calculations not done. The quantity Q*dp is carried by the + ! physics buffer across timesteps. It must be converted to Q (dry static energy + ! tendency) before being passed to radheat_tend. + qrs(:ncol,:) = qrs(:ncol,:) / state%pdel(:ncol,:) + qrl(:ncol,:) = qrl(:ncol,:) / state%pdel(:ncol,:) end if ! if (dosw .or. dolw) then @@ -1453,10 +1437,8 @@ subroutine radiation_tend( & ! The radiative heating rates are carried in the physics buffer across timesteps ! as Q*dp (for energy conservation). - if (conserve_energy) then - qrs(1:ncol,1:pver) = qrs(1:ncol,1:pver) * state%pdel(1:ncol,1:pver) - qrl(1:ncol,1:pver) = qrl(1:ncol,1:pver) * state%pdel(1:ncol,1:pver) - end if + qrs(:ncol,:) = qrs(:ncol,:) * state%pdel(:ncol,:) + qrl(:ncol,:) = qrl(:ncol,:) * state%pdel(:ncol,:) if (.not. present(rd_out)) then deallocate(rd%fsdn, rd%fsdnc, rd%fsup, rd%fsupc, & @@ -1715,7 +1697,6 @@ subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) real(r8), pointer :: fsnt(:) real(r8), pointer :: fsns(:) real(r8), pointer :: fsds(:) - real(r8), pointer :: su(:,:),sd(:,:),lu(:,:),ld(:,:) real(r8) :: ftem(pcols) !---------------------------------------------------------------------------- @@ -1775,12 +1756,11 @@ end subroutine radiation_output_sw !=============================================================================== -subroutine radiation_output_cld(lchnk, ncol, rd) +subroutine radiation_output_cld(lchnk, rd) ! Dump shortwave cloud optics information to history buffer. integer , intent(in) :: lchnk - integer, intent(in) :: ncol type(rad_out_t), intent(in) :: rd !---------------------------------------------------------------------------- @@ -1859,36 +1839,6 @@ end subroutine radiation_output_lw !=============================================================================== -subroutine calc_col_mean(state, mmr_pointer, mean_value) - - ! Compute the column mean mass mixing ratio. - - type(physics_state), intent(in) :: state - real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) - real(r8), dimension(pcols), intent(out) :: mean_value ! column mean mmr - - integer :: i, k, ncol - real(r8) :: ptot(pcols) - !----------------------------------------------------------------------- - - ncol = state%ncol - mean_value = 0.0_r8 - ptot = 0.0_r8 - - do k=1,pver - do i=1,ncol - mean_value(i) = mean_value(i) + mmr_pointer(i,k)*state%pdeldry(i,k) - ptot(i) = ptot(i) + state%pdeldry(i,k) - end do - end do - do i=1,ncol - mean_value(i) = mean_value(i) / ptot(i) - end do - -end subroutine calc_col_mean - -!========================================================================================= - subroutine coefs_init(coefs_file, available_gases, kdist) ! Read data from coefficients file. Initialize the kdist object. @@ -1916,7 +1866,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) gpt, & temperature_Planck - integer :: i, j, k + integer :: i integer :: did, vid integer :: ierr @@ -1928,11 +1878,10 @@ subroutine coefs_init(coefs_file, available_gases, kdist) real(r8) :: press_ref_trop, temp_ref_t, temp_ref_p real(r8), dimension(:,:,:), allocatable :: vmr_ref real(r8), dimension(:,:,:,:), allocatable :: kmajor - ! ? real(r8), dimension(:,:,:), allocatable :: selfrefin, forrefin real(r8), dimension(:,:,:), allocatable :: kminor_lower, kminor_upper real(r8), dimension(:,:), allocatable :: totplnk real(r8), dimension(:,:,:,:), allocatable :: planck_frac - real(r8), dimension(:), allocatable :: solar_src_quiet, solar_src_facular, solar_src_sunspot ! updated from solar_src + real(r8), dimension(:), allocatable :: solar_src_quiet, solar_src_facular, solar_src_sunspot real(r8) :: tsi_default real(r8), dimension(:,:,:), allocatable :: rayl_lower, rayl_upper character(len=32), dimension(:), allocatable :: gas_minor, & @@ -1973,8 +1922,6 @@ subroutine coefs_init(coefs_file, available_gases, kdist) call pio_seterrorhandling(fh, PIO_BCAST_ERROR) - ! Get variables and validate them, then put into kdist - ! Get dimensions and check for consistency with parameter values ierr = pio_inq_dimid(fh, 'absorber', did) @@ -2042,9 +1989,8 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_inq_dimlen(fh, did, fit_coeffs) end if - ! Get variables - + ! names of absorbing gases allocate(gas_names(absorber)) ierr = pio_inq_varid(fh, 'gas_names', vid) @@ -2120,21 +2066,6 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_get_var(fh, vid, kmajor) if (ierr /= PIO_NOERR) call endrun(sub//': error reading kmajor') - ! -bpm - variable wv_self & wv_for not in the newer files. - ! ! absorption coefficients due to water vapor self continuum - ! allocate(selfrefin(gpt,mixing_fraction,temperature)) - ! ierr = pio_inq_varid(fh, 'wv_self', vid) - ! if (ierr /= PIO_NOERR) call endrun(sub//': wv_self not found') - ! ierr = pio_get_var(fh, vid, selfrefin) - ! if (ierr /= PIO_NOERR) call endrun(sub//': error reading wv_self') - - ! ! absorption coefficients due to water vapor foreign continuum - ! allocate(forrefin(gpt,mixing_fraction,temperature)) - ! ierr = pio_inq_varid(fh, 'wv_for', vid) - ! if (ierr /= PIO_NOERR) call endrun(sub//': wv_for not found') - ! ierr = pio_get_var(fh, vid, forrefin) - ! if (ierr /= PIO_NOERR) call endrun(sub//': error reading wv_for') - ! absorption coefficients due to minor absorbing gases in lower part of atmosphere allocate(kminor_lower(contributors_lower, mixing_fraction, temperature)) ierr = pio_inq_varid(fh, 'kminor_lower', vid) @@ -2225,7 +2156,6 @@ subroutine coefs_init(coefs_file, available_gases, kdist) if (ierr /= PIO_NOERR) call endrun(sub//': error reading rayl_upper') end if - ! +bpm the others allocate(gas_minor(minorabsorbers)) ierr = pio_inq_varid(fh, 'gas_minor', vid) if (ierr /= PIO_NOERR) call endrun(sub//': gas_minor not found') @@ -2353,10 +2283,9 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! Close file call pio_closefile(fh) - ! Initialize the gas optics class with data. The calls look slightly different depending - ! on whether the radiation sources are internal to the atmosphere (longwave) or external (shortwave) - ! gas_optics%load() returns a string; a non-empty string indicates an error. - ! + ! Initialize the gas optics object with data. The calls look slightly different depending + ! on whether the radiation sources are internal to the atmosphere (longwave) or external (shortwave) + if (allocated(totplnk) .and. allocated(planck_frac)) then error_msg = kdist%load( & available_gases, gas_names, key_species, & @@ -2426,6 +2355,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) if (allocated(solar_src_sunspot)) deallocate(solar_src_sunspot) if (allocated(rayl_lower)) deallocate(rayl_lower) if (allocated(rayl_upper)) deallocate(rayl_upper) + end subroutine coefs_init !========================================================================================= @@ -2577,20 +2507,5 @@ end subroutine modified_cloud_fraction !========================================================================================= -elemental subroutine clipper(scalar, minval, maxval) - real(r8), intent(inout) :: scalar - real(r8), intent(in) :: minval, maxval - if (minval < maxval) then - if (scalar < minval) then - scalar = minval - end if - if (scalar > maxval) then - scalar = maxval - end if - end if -end subroutine clipper - -!========================================================================================= - end module radiation diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index e629950c64..caff2f6a71 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -125,9 +125,9 @@ subroutine rrtmgp_set_state( & real(r8), intent(out) :: alb_dif(nswbands,nday) ! surface albedo, diffuse radiation ! local variables - integer :: k, kk, i, iband + integer :: i, k, iband - real(r8) :: tref_min, tref_max, tmin, tmax + real(r8) :: tref_min, tref_max character(len=*), parameter :: sub='rrtmgp_set_state' character(len=512) :: errmsg @@ -497,7 +497,7 @@ subroutine rrtmgp_set_cloud_lw( & ! Local variables integer :: i, k, ncol - integer :: igpt, nver + integer :: nver ! cloud radiative parameters are "in cloud" not "in cell" real(r8) :: liq_lw_abs(nlwbands,pcols,pver) ! liquid absorption optics depth (LW) @@ -944,7 +944,7 @@ subroutine rrtmgp_set_aer_sw( & type(ty_optical_props_2str), intent(inout) :: aer_sw ! local variables - integer :: i, k, ib + integer :: i ! The optical arrays dimensioned in the vertical as 0:pver. ! The index 0 is for the extra layer used in the radiation @@ -958,7 +958,6 @@ subroutine rrtmgp_set_aer_sw( & real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! forward scattered fraction * w * tau ! aer_tau_w_f is not used by RRTMGP. character(len=*), parameter :: sub = 'rrtmgp_set_aer_sw' - character(len=128) :: errmsg !-------------------------------------------------------------------------------- ! Get aerosol shortwave optical properties. From 74bce491fec934f14d09b6d1e11d24e2eeeb251a Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 29 Sep 2023 14:22:56 -0400 Subject: [PATCH 36/53] remove some debug output; add error check routine --- src/physics/rrtmgp/radiation.F90 | 161 ++++++++----------------------- 1 file changed, 38 insertions(+), 123 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 9d551dd4c6..53dd2c1282 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -49,10 +49,10 @@ module radiation pio_def_var, pio_put_var, pio_get_var, & pio_put_att, PIO_NOWRITE, pio_closefile -use mo_source_functions, only: ty_source_func_lw use mo_gas_concentrations, only: ty_gas_concs use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str +use mo_source_functions, only: ty_source_func_lw use mo_fluxes_byband, only: ty_fluxes_byband use string_utils, only: to_lower @@ -108,21 +108,11 @@ module radiation real(r8) :: flux_sw_dn(pcols,pverp) ! downward flux real(r8) :: flux_sw_clr_dn(pcols,pverp) ! downward clearsky flux - real(r8), allocatable :: fsdn(:,:) ! Downward SW flux on rrtmgp grid - real(r8), allocatable :: fsdnc(:,:) ! Downward SW clear sky flux on rrtmgp grid - real(r8), allocatable :: fsup(:,:) ! Upward SW flux on rrtmgp grid - real(r8), allocatable :: fsupc(:,:) ! Upward SW clear sky flux on rrtmgp grid - 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_dn(pcols,pverp) ! downward flux real(r8) :: flux_lw_clr_dn(pcols,pverp) ! downward clearsky flux - real(r8), allocatable :: fldn(:,:) ! Downward LW flux on rrtmgp grid - real(r8), allocatable :: fldnc(:,:) ! Downward LW clear sky flux on rrtmgp grid - real(r8), allocatable :: flup(:,:) ! Upward LW flux on rrtmgp grid - real(r8), allocatable :: flupc(:,:) ! Upward LW clear sky flux on rrtmgp grid - real(r8) :: qrlc(pcols,pver) real(r8) :: flntc(pcols) ! Clear sky lw flux at model top @@ -490,9 +480,7 @@ subroutine radiation_init(pbuf2d) end do errmsg = available_gases%init(gaslist_lc) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: available_gases%init: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'available_gases%init') ! Read RRTMGP coefficients files and initialize kdist objects. call coefs_init(coefs_sw_file, available_gases, kdist_sw) @@ -644,16 +632,6 @@ subroutine radiation_init(pbuf2d) call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', & 'Shortwave clear-sky downward flux', sampling_seq='rad_lwsw') - ! Fluxes on RRTMGP grid - call addfld('FSDN'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & - 'SW downward flux on rrtmgp grid', sampling_seq='rad_lwsw') - call addfld('FSDNC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & - 'SW downward clear sky flux on rrtmgp grid', sampling_seq='rad_lwsw') - call addfld('FSUP'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & - 'SW upward flux on rrtmgp grid', sampling_seq='rad_lwsw') - call addfld('FSUPC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & - 'SW upward clear sky flux on rrtmgp grid', sampling_seq='rad_lwsw') - if (history_amwg) then call add_default('SOLIN'//diag(icall), 1, ' ') call add_default('QRS'//diag(icall), 1, ' ') @@ -723,16 +701,6 @@ subroutine radiation_init(pbuf2d) call addfld('FDLC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', & 'Longwave clear-sky downward flux', sampling_seq='rad_lwsw') - ! Fluxes on rrtmgp grid - call addfld('FLDN'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & - 'LW downward flux on rrtmgp grid', sampling_seq='rad_lwsw') - call addfld('FLDNC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & - 'LW downward clear sky flux on rrtmgp grid', sampling_seq='rad_lwsw') - call addfld('FLUP'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & - 'LW upward flux on rrtmgp grid', sampling_seq='rad_lwsw') - call addfld('FLUPC'//diag(icall), (/ 'plev_rad' /), 'I', 'W/m2', & - 'LW upward clear sky flux on rrtmgp grid', sampling_seq='rad_lwsw') - if (history_amwg) then call add_default('QRL'//diag(icall), 1, ' ') call add_default('FLNT'//diag(icall), 1, ' ') @@ -1006,11 +974,9 @@ subroutine radiation_tend( & real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth - real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables character(len=128) :: errmsg - character(len=*), parameter :: sub = 'radiation_tend' !-------------------------------------------------------------------------------------- @@ -1022,11 +988,6 @@ subroutine radiation_tend( & write_output = .false. else allocate(rd) - ! allocate elements of rd for output of fluxes on RRTMGP grid - if (.not. allocated(rd%fsdn)) then - allocate(rd%fsdn(pcols,nlay+1), rd%fsdnc(pcols,nlay+1), rd%fsup(pcols,nlay+1), rd%fsupc(pcols,nlay+1), & - rd%fldn(pcols,nlay+1), rd%fldnc(pcols,nlay+1), rd%flup(pcols,nlay+1), rd%flupc(pcols,nlay+1) ) - end if write_output = .true. end if @@ -1162,23 +1123,17 @@ subroutine radiation_tend( & ! Initialize object for gas concentrations. errmsg = gas_concs_sw%init(gaslist_lc) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: gas_concs_sw%init: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'gas_concs_sw%init') ! Initialize object for combined gas + aerosol + cloud optics. ! Allocates arrays for properties represented on g-points. errmsg = atm_optics_sw%alloc_2str(nday, nlay, kdist_sw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: gas_optics_sw%alloc_2str: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'atm_optics_sw%alloc_2str') ! Initialize object for SW aerosol optics. Allocates arrays ! for properties represented by band. errmsg = aer_sw%alloc_2str(nday, nlay, kdist_sw%get_band_lims_wavenumber()) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: aer_sw%alloc_2str: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'aer_sw%alloc_2str') end if @@ -1198,9 +1153,7 @@ subroutine radiation_tend( & errmsg = kdist_sw%gas_optics( & pmid_day, pint_day, t_day, gas_concs_sw, atm_optics_sw, & toa_flux) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: kdist_sw%gas_optics: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'kdist_sw%gas_optics') ! Scale the solar source tsi_ref = sum(toa_flux(1,:)) @@ -1218,31 +1171,23 @@ subroutine radiation_tend( & ! Increment the gas optics (in atm_optics_sw) by the aerosol optics in aer_sw. errmsg = aer_sw%increment(atm_optics_sw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in aer_sw%increment: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'aer_sw%increment') ! Compute clear-sky fluxes. errmsg = rte_sw(& atm_optics_sw, top_at_1, coszrs_day, toa_flux, & alb_dir, alb_dif, fswc) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in clear-sky rte_sw: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'clear-sky rte_sw') ! Increment the aerosol+gas optics (in atm_optics_sw) by the cloud optics in cloud_sw. errmsg = cloud_sw%increment(atm_optics_sw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in cloud_sw%increment: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'cloud_sw%increment') ! Compute all-sky fluxes. errmsg = rte_sw(& atm_optics_sw, top_at_1, coszrs_day, toa_flux, & alb_dir, alb_dif, fsw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in all-sky rte_sw: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'all-sky rte_sw') end if @@ -1270,9 +1215,7 @@ subroutine radiation_tend( & ! Initialize object for Planck sources. errmsg = sources_lw%alloc(ncol, nlay, kdist_lw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR, sources_lw%alloc: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'sources_lw%alloc') ! Set cloud optical properties in cloud_lw object. call rrtmgp_set_cloud_lw( & @@ -1282,21 +1225,15 @@ subroutine radiation_tend( & ! Initialize object for gas concentrations errmsg = gas_concs_lw%init(gaslist_lc) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR, gas_concs_lw%init: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'gas_concs_lw%init') ! Initialize object for combined gas + aerosol + cloud optics. errmsg = atm_optics_lw%alloc_1scl(ncol, nlay, kdist_lw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: gas_optics_lw%alloc_1scl: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'atm_optics_lw%alloc_1scl') ! Initialize object for LW aerosol optics. errmsg = aer_lw%alloc_1scl(ncol, nlay, kdist_lw%get_band_lims_wavenumber()) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: aer_lw%alloc_1scl: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'aer_lw%alloc_1scl') ! The climate (icall==0) calculation must occur last. do icall = N_DIAG, 0, -1 @@ -1310,33 +1247,26 @@ subroutine radiation_tend( & errmsg = kdist_lw%gas_optics( & pmid_rad, pint_rad, t_rad, t_sfc, gas_concs_lw, & atm_optics_lw, sources_lw) + call stop_on_err(errmsg, sub, 'kdist_lw%gas_optics') ! Set LW aerosol optical properties in the aer_lw object. call rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw) ! Increment the gas optics by the aerosol optics. errmsg = aer_lw%increment(atm_optics_lw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in aer_lw%increment: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'aer_lw%increment') ! Compute clear-sky LW fluxes errmsg = rte_lw(atm_optics_lw, top_at_1, sources_lw, emis_sfc, flwc) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in clear-sky rte_lw: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'clear-sky rte_lw') ! Increment the gas+aerosol optics by the cloud optics. errmsg = cloud_lw%increment(atm_optics_lw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in cloud_lw%increment: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'cloud_lw%increment') ! Compute all-sky LW fluxes errmsg = rte_lw(atm_optics_lw, top_at_1, sources_lw, emis_sfc, flw) - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR in all-sky rte_lw: '//trim(errmsg)) - end if + call stop_on_err(errmsg, sub, 'all-sky rte_lw') ! Transform RRTMGP outputs to CAM outputs and compute heating rates. call set_lw_diags() @@ -1441,8 +1371,6 @@ subroutine radiation_tend( & qrl(:ncol,:) = qrl(:ncol,:) * state%pdel(:ncol,:) if (.not. present(rd_out)) then - deallocate(rd%fsdn, rd%fsdnc, rd%fsup, rd%fsupc, & - rd%fldn, rd%fldnc, rd%flup, rd%flupc ) deallocate(rd) end if call free_optics_sw(atm_optics_sw) @@ -1487,11 +1415,6 @@ subroutine set_sw_diags() rd%flux_sw_clr_up = 0._r8 rd%flux_sw_clr_dn = 0._r8 - rd%fsdn = 0._r8 - rd%fsdnc = 0._r8 - rd%fsup = 0._r8 - rd%fsupc = 0._r8 - qrs = 0._r8 fsns = 0._r8 fsnt = 0._r8 @@ -1512,11 +1435,6 @@ subroutine set_sw_diags() rd%flux_sw_dn(idxday(i),ktopcam:) = fsw%flux_dn(i,ktoprad:) rd%flux_sw_clr_up(idxday(i),ktopcam:) = fswc%flux_up(i,ktoprad:) rd%flux_sw_clr_dn(idxday(i),ktopcam:) = fswc%flux_dn(i,ktoprad:) - - rd%fsdn(idxday(i),:) = fsw%flux_dn(i,:) - rd%fsdnc(idxday(i),:) = fswc%flux_dn(i,:) - rd%fsup(idxday(i),:) = fsw%flux_up(i,:) - rd%fsupc(idxday(i),:) = fswc%flux_up(i,:) end do ! Compute heating rate as a dry static energy tendency. @@ -1615,11 +1533,6 @@ subroutine set_lw_diags() rd%flut(:ncol) = flw%flux_up(:, ktoprad) rd%flutc(:ncol) = flwc%flux_up(:, ktoprad) - rd%fldn(:ncol,:) = flw%flux_dn - rd%fldnc(:ncol,:) = flwc%flux_dn - rd%flup(:ncol,:) = flw%flux_up - rd%flupc(:ncol,:) = flwc%flux_up - ! Output fluxes at 200 mb call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) @@ -1747,11 +1660,6 @@ subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) call outfld('FDS'//diag(icall), rd%flux_sw_dn, pcols, lchnk) call outfld('FDSC'//diag(icall), rd%flux_sw_clr_dn, pcols, lchnk) - call outfld('FSDN'//diag(icall), rd%fsdn, pcols, lchnk) - call outfld('FSDNC'//diag(icall), rd%fsdnc, pcols, lchnk) - call outfld('FSUP'//diag(icall), rd%fsup, pcols, lchnk) - call outfld('FSUPC'//diag(icall), rd%fsupc, pcols, lchnk) - end subroutine radiation_output_sw !=============================================================================== @@ -1830,11 +1738,6 @@ subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out) call outfld('FUL'//diag(icall), rd%flux_lw_up, pcols, lchnk) call outfld('FULC'//diag(icall), rd%flux_lw_clr_up, pcols, lchnk) - call outfld('FLDN'//diag(icall), rd%fldn, pcols, lchnk) - call outfld('FLDNC'//diag(icall), rd%fldnc, pcols, lchnk) - call outfld('FLUP'//diag(icall), rd%flup, pcols, lchnk) - call outfld('FLUPC'//diag(icall), rd%flupc, pcols, lchnk) - end subroutine radiation_output_lw !=============================================================================== @@ -1921,8 +1824,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) call pio_seterrorhandling(fh, PIO_BCAST_ERROR) - - ! Get dimensions and check for consistency with parameter values + ! Get dimensions ierr = pio_inq_dimid(fh, 'absorber', did) if (ierr /= PIO_NOERR) call endrun(sub//': absorber not found') @@ -2052,7 +1954,6 @@ 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 - ! vmr_ref(temperature, absorber_ext, atmos_layer) allocate(vmr_ref(atmos_layer, absorber_ext, temperature)) ierr = pio_inq_varid(fh, 'vmr_ref', vid) if (ierr /= PIO_NOERR) call endrun(sub//': vmr_ref not found') @@ -2283,7 +2184,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! Close file call pio_closefile(fh) - ! Initialize the gas optics object with data. The calls look slightly different depending + ! Initialize the gas optics object with data. The calls are slightly different depending ! on whether the radiation sources are internal to the atmosphere (longwave) or external (shortwave) if (allocated(totplnk) .and. allocated(planck_frac)) then @@ -2327,9 +2228,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) error_msg = 'must supply either totplnk and planck_frac, or solar_src_[*]' end if - if (len_trim(error_msg) > 0) then - call endrun(sub//': ERROR: '//trim(error_msg)) - end if + call stop_on_err(error_msg, sub, 'kdist%load') deallocate( & gas_names, key_species, & @@ -2507,5 +2406,21 @@ end subroutine modified_cloud_fraction !========================================================================================= +subroutine stop_on_err(errmsg, sub, info) + +! call endrun if RRTMGP function returns non-empty error message. + + character(len=*), intent(in) :: errmsg ! return message from RRTMGP function + character(len=*), intent(in) :: sub ! name of calling subroutine + character(len=*), intent(in) :: info ! name of called function + + if (len_trim(errmsg) > 0) then + call endrun(trim(sub)//': ERROR: '//trim(info)//': '//trim(errmsg)) + end if + +end subroutine stop_on_err + +!========================================================================================= + end module radiation From ddda4164a241ba2cd2651c0a9496fc66175a3178 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 29 Sep 2023 20:44:08 -0400 Subject: [PATCH 37/53] update build for changes to rte-rrtmgp develop branch --- .gitignore | 1 + Externals_CAM.cfg | 21 ++++++++++----- bld/build-namelist | 28 +++++++++++++++----- bld/configure | 20 +++++++------- bld/namelist_files/namelist_defaults_cam.xml | 4 +-- 5 files changed, 48 insertions(+), 26 deletions(-) diff --git a/.gitignore b/.gitignore index f845629454..fd86ccd9e0 100644 --- a/.gitignore +++ b/.gitignore @@ -11,6 +11,7 @@ src/physics/cosp2/src src/physics/silhs src/physics/pumas src/physics/pumas-frozen +src/physics/rrtmgp/data src/physics/rrtmgp/ext src/dynamics/fv3/atmos_cubed_sphere libraries/FMS diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index a0adb29d61..b9691c4e85 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -1,10 +1,3 @@ -[rrtmgp] -local_path = src/physics/rrtmgp/ext -protocol = git -repo_url = https://github.com/brian-eaton/rte-rrtmgp.git -tag = local_fix01 -required = True - [chem_proc] local_path = chem_proc protocol = git @@ -91,5 +84,19 @@ repo_url = https://github.com/ESCOMP/HEMCO_CESM.git required = True externals = Externals_HCO.cfg +[rte-rrtmgp] +local_path = src/physics/rrtmgp/ext +protocol = git +repo_url = https://github.com/earth-system-radiation/rte-rrtmgp.git +hash = a1b6781 +required = True + +[rrtmgp-data] +local_path = src/physics/rrtmgp/data +protocol = git +repo_url = https://github.com/earth-system-radiation/rrtmgp-data.git +tag = v1.7.1 +required = True + [externals_description] schema_version = 1.0.0 diff --git a/bld/build-namelist b/bld/build-namelist index 1b1012f524..bada94c795 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -693,15 +693,16 @@ my $rad_pkg = $cfg->get('rad'); if ($rad_pkg eq 'camrt') { add_default($nl, 'absems_data'); } -elsif ($rad_pkg eq 'rrtmgp') { - # Data for gas optics is provided with the source code. The paths to this data - # are relative to the root directory of the cam component. +elsif ($rad_pkg =~ m/rrtmgp/) { + # Dataset for gas optics are checked out of an external repo into + # the source code directory. The paths to this data are relative + # to the root directory of the cam component. my $cam_dir = $cfg->get('cam_dir'); add_default($nl, 'rrtmgp_coefs_lw_file'); my $rel_path = $nl->get_value('rrtmgp_coefs_lw_file'); my $abs_path = quote_string(set_abs_filepath($rel_path, $cam_dir)); - # need to overwrite the relative pathname with the absolute pathname in the namelist object + # Overwrite the relative pathname with the absolute pathname in the namelist object $nl->set_variable_value('radiation_nl', 'rrtmgp_coefs_lw_file', $abs_path); add_default($nl, 'rrtmgp_coefs_sw_file'); @@ -863,7 +864,6 @@ if ($chem_rad_passive or $aqua_mode) { # The aerosol optics depend on which radiative transfer model is used due to differing # wavelength bands used. -my $rrtmg = $rad_pkg eq 'rrtmg' ? 1 : 0; # @aero_names contains the names of the entities (bulk aerosols and modes) # that are externally mixed in aerosol optics calculation. These entities are all @@ -1242,7 +1242,7 @@ if ($carma eq 'bc_strat') { } } -if ($rrtmg) { +if ($rad_pkg eq 'rrtmg') { # CARMA Microphysics - RRTMG Only # @@ -1662,11 +1662,25 @@ if ($rad_pkg ne 'none') { } # Cloud optics -if ($rad_pkg =~ /rrtmg/) { # matches both rrtmg and rrtmgp +if ($rad_pkg =~ m/rrtmg/) { # matches both rrtmg and rrtmgp add_default($nl, 'liqcldoptics'); add_default($nl, 'icecldoptics'); add_default($nl, 'liqopticsfile'); add_default($nl, 'iceopticsfile'); + + # rrtmgp only implemented with mitchell and gammadist cloud optics + if ($rad_pkg =~ m/rrtmgp/) { + my $liqcldoptics = $nl->get_value('liqcldoptics'); + if ($liqcldoptics !~ m/gammadist/) { + die "$ProgName - ERROR: RRTMGP only implemented with gammadist liquid cloud optics\n" . + "liqcldoptics = $liqcldoptics\n"; + } + my $icecldoptics = $nl->get_value('icecldoptics'); + if ($icecldoptics !~ m/mitchell/) { + die "$ProgName - ERROR: RRTMGP only implemented with mitchell ice cloud optics\n" . + "icecldoptics = $icecldoptics\n"; + } + } } # Volcanic Aerosol Mass climatology dataset diff --git a/bld/configure b/bld/configure index a6a4ee804d..c199044857 100755 --- a/bld/configure +++ b/bld/configure @@ -1088,7 +1088,7 @@ if ($rad_pkg eq 'camrt') { " with aerosol package $chem_pkg\n"; } } -elsif ($rad_pkg eq 'rrtmg') { +elsif ($rad_pkg =~ m/rrtmg/) { # The rrtmg package doesn't work with the CAM3 prescribed aerosols if ($phys_pkg eq 'cam3') { @@ -1130,7 +1130,7 @@ if ($phys_pkg eq 'spcam_sam1mom') { } if ($phys_pkg eq 'spcam_m2005') { - if ($rad_pkg ne 'rrtmg') { + if ($rad_pkg !~ m/rrtmg/) { die "configure ERROR: radiation package: $rad_pkg is not compatible\n". " with m2005 -- it should be rrtmg\n"; } @@ -2212,16 +2212,16 @@ sub write_filepath } elsif ($rad eq 'rrtmgp') { print $fh "$camsrcdir/src/physics/rrtmgp\n"; - print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp\n"; - print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/extensions\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/gas-optics\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp-frontend\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte-frontend\n"; if ($use_rrtmgp_gpu) { - print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp/kernels-openacc\n"; - print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte/kernels-openacc\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp-kernels/accel\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte-kernels/accel\n"; } - print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp/kernels\n"; - print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte/kernels\n"; - print $fh "$camsrcdir/src/physics/rrtmgp/ext/extensions\n"; - print $fh "$camsrcdir/src/physics/rrtmgp/ext/extensions/cloud_optics\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp-kernels\n"; + print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte-kernels\n"; } if ($clubb_sgs) { diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index d361e48955..b1768fae57 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -589,8 +589,8 @@ atm/cam/physprops/iceoptics_c080917.nc atm/cam/physprops/F_nwvl200_mu20_lam50_res64_t298_c080428.nc -src/physics/rrtmgp/ext/rrtmgp/data/rrtmgp-data-lw-g128-210809.nc -src/physics/rrtmgp/ext/rrtmgp/data/rrtmgp-data-sw-g112-210809.nc +src/physics/rrtmgp/data/rrtmgp-gas-lw-g128.nc +src/physics/rrtmgp/data/rrtmgp-gas-sw-g112.nc atm/cam/rad/abs_ems_factors_fastvx.c030508.nc From 0a6e8a5dfa7dbab274c15f6341eece1b79a4299c Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 6 Oct 2023 19:16:57 -0400 Subject: [PATCH 38/53] remove null() init in pointer declarations for thread safety --- Externals.cfg | 10 +++---- src/physics/rrtmgp/radiation.F90 | 45 +++++++++++++--------------- src/physics/rrtmgp/rrtmgp_inputs.F90 | 38 ++++++++--------------- 3 files changed, 39 insertions(+), 54 deletions(-) diff --git a/Externals.cfg b/Externals.cfg index 9badad437d..95914651eb 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -1,7 +1,7 @@ [ccs_config] -tag = ccs_config_cesm0.0.73 +hash = 980862e protocol = git -repo_url = https://github.com/ESMCI/ccs_config_cesm +repo_url = https://github.com/brian-eaton/ccs_config_cesm local_path = ccs_config required = True @@ -21,7 +21,7 @@ externals = Externals.cfg required = True [cmeps] -tag = cmeps0.14.34 +tag = cmeps0.14.39 protocol = git repo_url = https://github.com/ESCOMP/CMEPS.git local_path = components/cmeps @@ -36,7 +36,7 @@ externals = Externals_CDEPS.cfg required = True [cpl7] -tag = cpl77.0.5 +tag = cpl77.0.6 protocol = git repo_url = https://github.com/ESCOMP/CESM_CPL7andDataComps local_path = components/cpl7 @@ -64,7 +64,7 @@ local_path = libraries/parallelio required = True [cime] -tag = cime6.0.125 +tag = cime6.0.156 protocol = git repo_url = https://github.com/ESMCI/cime local_path = cime diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 53dd2c1282..01d4a057cb 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -36,7 +36,6 @@ module radiation use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active -use cam_history_support, only: add_vert_coord use radiation_data, only: rad_data_register, rad_data_init @@ -169,8 +168,8 @@ module radiation integer :: fsnt_idx = 0 integer :: flns_idx = 0 integer :: flnt_idx = 0 -integer :: cldfsnow_idx = 0 integer :: cld_idx = 0 +integer :: cldfsnow_idx = 0 integer :: cldfgrau_idx = 0 character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ',& @@ -183,6 +182,10 @@ module radiation ! Number of layers in radiation calculations. integer :: nlay +! Number of CAM layers in radiation calculations. Is either equal to nlay, or is +! 1 less than nlay if "extra layer" is used in the radiation calculations. +integer :: nlaycam + ! Indices for copying data between CAM/WACCM and RRTMGP arrays. Since RRTMGP is ! vertical order agnostic we can send data using the top to bottom order used ! in CAM/WACCM. But the number of layers that RRTMGP does computations for @@ -198,9 +201,6 @@ module radiation ! Note: for CAM's top to bottom indexing, the index of a given layer ! (midpoint) and the upper interface of that layer, are the same. -! vertical coordinate for output of fluxes on radiation grid -real(r8), allocatable, target :: plev_rad(:) - ! Gas optics objects contain the data read from the coefficients files. type(ty_gas_optics_rrtmgp) :: kdist_sw type(ty_gas_optics_rrtmgp) :: kdist_lw @@ -452,26 +452,21 @@ subroutine radiation_init(pbuf2d) ! below 1 Pa then an extra layer is added to the top of the model for ! the purpose of the radiation calculation. nlay = count( pref_edge(:) > 1._r8 ) ! pascals (0.01 mbar) - allocate(plev_rad(nlay+1)) if (nlay == pverp) then ! Top model interface is below 1 Pa. RRTMGP is active in all model layers plus ! 1 extra layer between model top and 1 Pa. ktopcam = 1 ktoprad = 2 - plev_rad(1) = 1.01_r8 ! Top of extra layer, Pa. - plev_rad(2:) = pref_edge + nlaycam = pver else - ! nlay < pverp. nlay layers are set by radiation - ktopcam = pverp - nlay + 1 + ! nlay < pverp. nlay layers are used in radiation calcs, and they are + ! all CAM layers. + ktopcam = pver - nlay + 1 ktoprad = 1 - plev_rad = pref_edge(ktopcam:) + nlaycam = nlay end if - ! Define a pressure coordinate to allow output of data on the radiation grid. - call add_vert_coord('plev_rad', nlay+1, 'Pressures at radiation flux calculations', & - 'Pa', plev_rad) - ! Create lowercase version of the gaslist for RRTMGP. The ty_gas_concs objects ! work with CAM's uppercase names, but other objects that get input from the gas ! concs objects don't work. @@ -499,8 +494,8 @@ subroutine radiation_init(pbuf2d) call cloud_rad_props_init() cld_idx = pbuf_get_index('CLD') - cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=ierr) - cldfgrau_idx = pbuf_get_index('CLDFGRAU',errcode=ierr) + cldfsnow_idx = pbuf_get_index('CLDFSNOW', errcode=ierr) + cldfgrau_idx = pbuf_get_index('CLDFGRAU', errcode=ierr) if (is_first_step()) then call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) @@ -885,11 +880,11 @@ subroutine radiation_tend( & integer :: itim_old real(r8), pointer :: cld(:,:) ! cloud fraction - real(r8), pointer :: cldfsnow(:,:) => null() ! cloud fraction of just "snow clouds" - real(r8), pointer :: cldfgrau(:,:) => null() ! cloud fraction of just "graupel clouds" + real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds" + real(r8), pointer :: cldfgrau(:,:) ! cloud fraction of just "graupel clouds" real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction - real(r8), pointer :: qrs(:,:) => null() ! shortwave radiative heating rate - real(r8), pointer :: qrl(:,:) => null() ! longwave radiative heating rate + real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate + real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate real(r8), pointer :: fsds(:) ! Surface solar down flux real(r8), pointer :: fsns(:) ! Surface solar absorbed flux real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top @@ -1029,9 +1024,11 @@ subroutine radiation_tend( & ! Associate pointers to physics buffer fields itim_old = pbuf_old_tim_idx() + nullify(cldfsnow) if (cldfsnow_idx > 0) then call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) end if + nullify(cldfgrau) if (cldfgrau_idx > 0 .and. graupel_in_rad) then call pbuf_get_field(pbuf, cldfgrau_idx, cldfgrau, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) endif @@ -1219,9 +1216,9 @@ subroutine radiation_tend( & ! Set cloud optical properties in cloud_lw object. call rrtmgp_set_cloud_lw( & - state, pbuf, nlay, cld, cldfsnow, & - cldfgrau, cldfprime, graupel_in_rad, kdist_lw, cloud_lw, & - cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, grau_lw_abs_cloudsim ) + state, pbuf, ncol, nlay, nlaycam, & + cld, cldfsnow, cldfgrau, cldfprime, graupel_in_rad, & + kdist_lw, cloud_lw, cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, grau_lw_abs_cloudsim) ! Initialize object for gas concentrations errmsg = gas_concs_lw%init(gaslist_lc) diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index caff2f6a71..7f5cda89a4 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -316,14 +316,14 @@ subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, ga integer, optional, intent(in) :: idxday(:) ! indices of daylight columns in a chunk - ! local + ! Local variables integer :: i, idx(numactivecols) real(r8), pointer :: gas_mmr(:,:) real(r8), allocatable :: gas_vmr(:,:) real(r8), allocatable :: mmr(:,:) real(r8) :: massratio - ! -- for ozone profile above model + ! For ozone profile above model real(r8) :: P_top, P_int, P_mid, alpha, beta, a, b, chi_mid, chi_0, chi_eff character(len=128) :: errmsg @@ -468,9 +468,9 @@ end subroutine rrtmgp_set_gases_sw !================================================================================================== subroutine rrtmgp_set_cloud_lw( & - state, pbuf, nlay, cld, cldfsnow, & - cldfgrau, cldfprime, graupel_in_rad, kdist_lw, cloud_lw, & - cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, grau_lw_abs_cloudsim ) + state, pbuf, ncol, nlay, nlaycam, & + cld, cldfsnow, cldfgrau, cldfprime, graupel_in_rad, & + kdist_lw, cloud_lw, cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, grau_lw_abs_cloudsim) ! Compute combined cloud optical properties. ! Create MCICA stochastic arrays for cloud LW optical properties. @@ -479,7 +479,9 @@ subroutine rrtmgp_set_cloud_lw( & ! arguments type(physics_state), intent(in) :: state type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: ncol ! number of columns in CAM chunk integer, intent(in) :: nlay ! number of layers in radiation calculation (may include "extra layer") + integer, intent(in) :: nlaycam ! number of CAM layers in radiation calculation real(r8), pointer :: cld(:,:) ! cloud fraction (liq+ice) real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds" real(r8), pointer :: cldfgrau(:,:) ! cloud fraction of just "graupel clouds" @@ -496,8 +498,7 @@ subroutine rrtmgp_set_cloud_lw( & ! Local variables - integer :: i, k, ncol - integer :: nver + integer :: i, k ! cloud radiative parameters are "in cloud" not "in cell" real(r8) :: liq_lw_abs(nlwbands,pcols,pver) ! liquid absorption optics depth (LW) @@ -508,16 +509,14 @@ subroutine rrtmgp_set_cloud_lw( & real(r8) :: c_cld_lw_abs(nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) ! Arrays for converting from CAM chunks to RRTMGP inputs. - real(r8), allocatable :: cldf(:,:) - real(r8), allocatable :: tauc(:,:,:) - real(r8), allocatable :: taucmcl(:,:,:) + real(r8) :: cldf(ncol,nlaycam) + real(r8) :: tauc(nlwbands,ncol,nlaycam) + real(r8) :: taucmcl(nlwgpts,ncol,nlaycam) character(len=128) :: errmsg character(len=*), parameter :: sub = 'rrtmgp_set_cloud_lw' !-------------------------------------------------------------------------------- - ncol = state%ncol - ! Combine the cloud optical properties. These calculations are done on CAM "chunks". ! gammadist liquid optics @@ -566,22 +565,14 @@ subroutine rrtmgp_set_cloud_lw( & ! Extract just the layers of CAM where RRTMGP does calculations. - ! number of CAM's layers in radiation calculation. Does not include the "extra layer". - nver = pver - ktopcam + 1 - - allocate( & - cldf(ncol,nver), & - tauc(nlwbands,ncol,nver), & - taucmcl(nlwgpts,ncol,nver) ) - ! Subset "chunk" data so just the number of CAM layers in the ! radiation calculation are used by MCICA to produce subcolumns. cldf = cldfprime(:ncol, ktopcam:) tauc = c_cld_lw_abs(:, :ncol, ktopcam:) call mcica_subcol_lw( & - kdist_lw, nlwbands, nlwgpts, ncol, nver, & - nlwgpts, state%pmid, cldf, tauc, taucmcl ) + kdist_lw, nlwbands, nlwgpts, ncol, nlaycam, & + nlwgpts, state%pmid, cldf, tauc, taucmcl ) errmsg =cloud_lw%alloc_1scl(ncol, nlay, kdist_lw) if (len_trim(errmsg) > 0) then @@ -603,9 +594,6 @@ subroutine rrtmgp_set_cloud_lw( & call endrun(sub//': ERROR: cloud_lw%validate: '//trim(errmsg)) end if - ! All information is in cloud_lw, now deallocate local vars. - deallocate(cldf, tauc, taucmcl) - end subroutine rrtmgp_set_cloud_lw !================================================================================================== From 52bdd66e0ee3fbb30f94e3b7183b97472f4562d7 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 12 Oct 2023 19:30:57 -0400 Subject: [PATCH 39/53] update ccs_config external --- Externals.cfg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Externals.cfg b/Externals.cfg index 8a4baa7dfb..5110afadb8 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -1,7 +1,7 @@ [ccs_config] -hash = 980862e +tag = ccs_config_cesm0.0.79 protocol = git -repo_url = https://github.com/brian-eaton/ccs_config_cesm +repo_url = https://github.com/ESMCI/ccs_config_cesm local_path = ccs_config required = True From b489af0fbb554e39affd2acec66e8dead782b9f2 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Fri, 13 Oct 2023 12:04:25 -0400 Subject: [PATCH 40/53] modify initialization in cam_dev to match cam --- src/physics/cam_dev/physpkg.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/physics/cam_dev/physpkg.F90 b/src/physics/cam_dev/physpkg.F90 index b288a17177..ba945def14 100644 --- a/src/physics/cam_dev/physpkg.F90 +++ b/src/physics/cam_dev/physpkg.F90 @@ -837,16 +837,19 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! low level, so init it early. Must at least do this before radiation. call wv_sat_init + ! solar irradiance data modules + call solar_data_init() + ! Initialize rad constituents and their properties call rad_cnst_init() + + call radiation_init(pbuf2d) + call aer_rad_props_init() ! initialize carma call carma_init() - ! solar irradiance data modules - call solar_data_init() - ! Prognostic chemistry. call chem_init(phys_state,pbuf2d) @@ -882,8 +885,6 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) endif endif - call radiation_init(pbuf2d) - call cloud_diagnostics_init() call radheat_init(pref_mid) From 7ce9dd8d44b20d7c90716c32e2f1a90181d153ee Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 17 Oct 2023 15:16:15 -0600 Subject: [PATCH 41/53] add limits on P and T for FMTHIST --- src/physics/rrtmgp/rrtmgp_inputs.F90 | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 7f5cda89a4..938be91767 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -154,23 +154,20 @@ subroutine rrtmgp_set_state( & ! The top reference pressure from the RRTMGP coefficients datasets is 1.005183574463 Pa ! Set the top of the extra layer just below that. pint_rad(:,1) = 1.01_r8 + else + ! nlay < pverp, thus the 1 Pa level is within a CAM layer. Assuming the top interface of + ! this layer is at a pressure < 1 Pa, we need to adjust the top of this layer so that it + ! is within the valid pressure range of RRTMGP (otherwise RRTMGP issues an error). Then + ! set the midpoint pressure halfway between the interfaces. + pint_rad(:,1) = 1.01_r8 + pmid_rad(:,1) = 0.5_r8 * (pint_rad(:,1) + pint_rad(:,2)) end if - ! Check that the temperatures are within the limits of RRTMGP validity. + ! Limit temperatures to be within the limits of RRTMGP validity. tref_min = kdist_sw%get_temp_min() tref_max = kdist_sw%get_temp_max() - if ( any(t_rad < tref_min) .or. any(t_rad > tref_max) ) then - ! Report out of range value and quit. - do i = 1, ncol - do k = 1, nlay - if ( t_rad(i,k) < tref_min .or. t_rad(i,k) > tref_max ) then - write(errmsg,*) 'temp outside valid range: ', t_rad(i,k), ': column lat=', & - state%lat(i)*180._r8/pi, ': column lon=', state%lon(i)*180._r8/pi, ': level idx=',k - call endrun(sub//': ERROR, '//errmsg) - end if - end do - end do - end if + t_rad = merge(t_rad, tref_min, t_rad > tref_min) + t_rad = merge(t_rad, tref_max, t_rad < tref_max) ! Construct arrays containing only daylight columns do i = 1, nday From af0446aa994783a1195e09c1db3e6b931094fe04 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 18 Oct 2023 11:11:53 -0600 Subject: [PATCH 42/53] fix namelist and cloud optics indexing for waccm --- bld/namelist_files/namelist_defaults_cam.xml | 21 ++++++++++++++++---- src/physics/rrtmgp/rrtmgp_inputs.F90 | 14 ++++++++----- 2 files changed, 26 insertions(+), 9 deletions(-) diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index b1768fae57..31faecaed3 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -456,7 +456,7 @@ atm/cam/physprops/ssam_rrtmg_c080918.nc atm/cam/physprops/sscm_rrtmg_c080918.nc - + atm/cam/physprops/sulfate_rrtmg_c080918.nc atm/cam/physprops/sulfate_rrtmg_c080918.nc atm/cam/physprops/dust1_rrtmg_c080918.nc @@ -497,7 +497,8 @@ atm/cam/physprops/ssam_rrtmg_c100508.nc atm/cam/physprops/dust_aeronet_rrtmg_c141106.nc atm/cam/physprops/sulfate_rrtmg_c080918.nc - + + atm/cam/physprops/sulfate_rrtmg_c080918.nc atm/cam/physprops/ocpho_rrtmg_c101112.nc atm/cam/physprops/ocpho_rrtmg_c130709.nc @@ -514,7 +515,8 @@ atm/cam/physprops/volc_camRRTMG_byradius_sigma1.6_mode1_c210211.nc atm/cam/physprops/volc_camRRTMG_byradius_sigma1.6_mode2_c210211.nc atm/cam/physprops/volc_camRRTMG_byradius_sigma1.2_mode3_c210211.nc - + + atm/cam/physprops/volc_camRRTMG_byradius_sigma1.6_c130724.nc atm/cam/physprops/volc_camRRTMG_byradius_sigma1.6_mode1_c210211.nc atm/cam/physprops/volc_camRRTMG_byradius_sigma1.6_mode2_c210211.nc @@ -549,18 +551,29 @@ atm/cam/physprops/mam7_mode5_rrtmg_c120904.nc atm/cam/physprops/mam7_mode6_rrtmg_c120904.nc atm/cam/physprops/mam7_mode7_rrtmg_c120904.nc - + + atm/cam/physprops/mam4_mode1_rrtmg_aeronetdust_c141106.nc atm/cam/physprops/mam4_mode2_rrtmg_aitkendust_c141106.nc atm/cam/physprops/mam4_mode3_rrtmg_aeronetdust_c141106.nc + atm/cam/physprops/mam4_mode1_rrtmg_aeronetdust_sig1.6_dgnh.48_c140304.nc atm/cam/physprops/mam4_mode3_rrtmg_aeronetdust_sig1.2_dgnl.40_c150219.nc + atm/cam/physprops/mam4_mode1_rrtmg_aeronetdust_c141106.nc atm/cam/physprops/mam4_mode2_rrtmg_aitkendust_c141106.nc atm/cam/physprops/mam4_mode3_rrtmg_aeronetdust_c141106.nc atm/cam/physprops/mam4_mode4_rrtmg_c130628.nc + atm/cam/physprops/mam4_mode1_rrtmg_aeronetdust_sig1.6_dgnh.48_c140304.nc atm/cam/physprops/mam4_mode3_rrtmg_aeronetdust_sig1.2_dgnl.40_c150219.nc + +atm/cam/physprops/mam4_mode1_rrtmg_aeronetdust_sig1.6_dgnh.48_c140304.nc +atm/cam/physprops/mam4_mode2_rrtmg_aitkendust_c141106.nc +atm/cam/physprops/mam4_mode3_rrtmg_aeronetdust_c141106.nc +atm/cam/physprops/mam4_mode4_rrtmg_c130628.nc +atm/cam/physprops/mam4_mode3_rrtmg_aeronetdust_sig1.2_dgnl.40_c150219.nc + atm/cam/physprops/mam7_mode1_rrtmg_c120904.nc atm/cam/physprops/mam7_mode2_rrtmg_c120904.nc atm/cam/physprops/mam7_mode3_rrtmg_c120904.nc diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 938be91767..93b32b007f 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -566,7 +566,11 @@ subroutine rrtmgp_set_cloud_lw( & ! radiation calculation are used by MCICA to produce subcolumns. cldf = cldfprime(:ncol, ktopcam:) tauc = c_cld_lw_abs(:, :ncol, ktopcam:) + + ! Enforce tauc >= 0. + tauc = merge(tauc, 0.0_r8, tauc > 0.0_r8) + ! MCICA uses spectral data (on bands) to construct subcolumns (one per g-point) call mcica_subcol_lw( & kdist_lw, nlwbands, nlwgpts, ncol, nlaycam, & nlwgpts, state%pmid, cldf, tauc, taucmcl ) @@ -582,7 +586,7 @@ subroutine rrtmgp_set_cloud_lw( & ! Set the properties on g-points. do i = 1, nlwgpts - cloud_lw%tau(:ncol, ktoprad:, i) = taucmcl(i, :ncol, ktopcam:) + cloud_lw%tau(:,ktoprad:,i) = taucmcl(i,:,:) end do ! validate checks that: tau > 0 @@ -823,7 +827,7 @@ subroutine rrtmgp_set_cloud_sw( & ! set asymmetry to zero when tauc = 0 asmc = merge(asmc, 0.0_r8, tauc > 0.0_r8) - ! MCICA converts from bands to gpts (e.g., 224 g-points instead of 14 bands) + ! MCICA uses spectral data (on bands) to construct subcolumns (one per g-point) call mcica_subcol_sw( & kdist_sw, nswbands, nswgpts, nday, nlay, & nver, changeseed, pmid, cldf, tauc, & @@ -843,9 +847,9 @@ subroutine rrtmgp_set_cloud_sw( & ! Set the properties on g-points. do igpt = 1,nswgpts - cloud_sw%g (:, ktoprad:, igpt) = asmcmcl(igpt, ktopcam:, :) - cloud_sw%ssa(:, ktoprad:, igpt) = ssacmcl(igpt, ktopcam:, :) - cloud_sw%tau(:, ktoprad:, igpt) = taucmcl(igpt, ktopcam:, :) + cloud_sw%g (:,ktoprad:,igpt) = asmcmcl(igpt,:,:) + cloud_sw%ssa(:,ktoprad:,igpt) = ssacmcl(igpt,:,:) + cloud_sw%tau(:,ktoprad:,igpt) = taucmcl(igpt,:,:) end do ! validate checks that: tau > 0, ssa is in range [0,1], and g is in range [-1,1]. From 18efa42822fc02556edb2dedf7519a7bb0fafe0c Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Thu, 19 Oct 2023 12:39:11 -0400 Subject: [PATCH 43/53] replace 1 by ktopcam in a few places for high top models --- src/physics/rrtmgp/radiation.F90 | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 01d4a057cb..5af989e7fe 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1327,9 +1327,10 @@ subroutine radiation_tend( & ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave ! optical depths are passed. - call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & - cld_swtau_in=cld_tau_cloudsim,& - snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) + call cospsimulator_intr_run( & + state, pbuf, cam_in, emis, coszrs, & + cld_swtau_in=cld_tau_cloudsim, snow_tau_in=gb_snow_tau, & + snow_emis_in=gb_snow_lw) cosp_cnt(lchnk) = 0 end if end if ! docosp @@ -1438,10 +1439,10 @@ subroutine set_sw_diags() call heating_rate('SW', ncol, fns, qrs) call heating_rate('SW', ncol, fcns, rd%qrsc) - fsns(:ncol) = fns(:ncol,pverp) ! net sw flux at surface - fsnt(:ncol) = fns(:ncol,1) ! net sw flux at top-of-model (w/o extra layer) - rd%fsnsc(:ncol) = fcns(:ncol,pverp) ! net sw clearsky flux at surface - rd%fsntc(:ncol) = fcns(:ncol,1) ! net sw clearsky flux at top + fsns(:ncol) = fns(:ncol,pverp) ! net sw flux at surface + fsnt(:ncol) = fns(:ncol,ktopcam) ! net sw flux at top-of-model (w/o extra layer) + rd%fsnsc(:ncol) = fcns(:ncol,pverp) ! net sw clearsky flux at surface + rd%fsntc(:ncol) = fcns(:ncol,ktopcam) ! net sw clearsky flux at top cam_out%netsw(:ncol) = fsns(:ncol) @@ -1519,10 +1520,10 @@ subroutine set_lw_diags() call heating_rate('LW', ncol, fcnl, rd%qrlc) flns(:ncol) = fnl(:ncol, pverp) - flnt(:ncol) = fnl(:ncol, 1) + flnt(:ncol) = fnl(:ncol, ktopcam) rd%flnsc(:ncol) = fcnl(:ncol, pverp) - rd%flntc(:ncol) = fcnl(:ncol, 1) ! net lw flux at top-of-model + rd%flntc(:ncol) = fcnl(:ncol, ktopcam) ! net lw flux at top-of-model cam_out%flwds(:ncol) = flw%flux_dn(:, nlay+1) rd%fldsc(:ncol) = flwc%flux_dn(:, nlay+1) @@ -1563,10 +1564,13 @@ subroutine heating_rate(type, ncol, flux_net, hrate) ! local vars integer :: k + ! Initialize for layers where RRTMGP is not providing fluxes. + hrate = 0.0_r8 + select case (type) case ('LW') - do k = 1, pver + 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) @@ -1574,7 +1578,7 @@ subroutine heating_rate(type, ncol, flux_net, hrate) case ('SW') - do k = 1, pver + do k = ktopcam, pver ! top - bottom hrate(:ncol,k) = (flux_net(:ncol,k) - flux_net(:ncol,k+1)) * & gravit / state%pdel(:ncol,k) From 3e7282b7e1a0653e63abe80e829162aa472c7a89 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 24 Oct 2023 18:26:27 -0400 Subject: [PATCH 44/53] add tests; update ChangeLog --- cime_config/testdefs/testlist_cam.xml | 43 +++++ .../cam/cam6_port_f09_rrtmgp/shell_commands | 3 + .../cam/cam6_port_f09_rrtmgp/user_nl_cam | 15 ++ .../cam/outfrq9s_rrtmgp/shell_commands | 3 + .../cam/outfrq9s_rrtmgp/user_nl_cam | 4 + .../cam/outfrq9s_rrtmgp/user_nl_clm | 27 +++ .../usermods_dirs/rrtmgp/shell_commands | 7 - cime_config/usermods_dirs/rrtmgp/user_nl_cam | 11 -- .../usermods_dirs/scam_rrtmgp/shell_commands | 21 --- .../usermods_dirs/scam_rrtmgp/user_nl_cam | 15 -- doc/ChangeLog | 161 ++++++++++++++++++ src/physics/cam/phys_prop.F90 | 4 +- src/physics/spcam/crm/CLUBB/crmx_mt95.f90 | 6 +- 13 files changed, 260 insertions(+), 60 deletions(-) create mode 100644 cime_config/testdefs/testmods_dirs/cam/cam6_port_f09_rrtmgp/shell_commands create mode 100644 cime_config/testdefs/testmods_dirs/cam/cam6_port_f09_rrtmgp/user_nl_cam create mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/shell_commands create mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/user_nl_cam create mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/user_nl_clm delete mode 100755 cime_config/usermods_dirs/rrtmgp/shell_commands delete mode 100644 cime_config/usermods_dirs/rrtmgp/user_nl_cam delete mode 100755 cime_config/usermods_dirs/scam_rrtmgp/shell_commands delete mode 100644 cime_config/usermods_dirs/scam_rrtmgp/user_nl_cam diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 854ad1ac5a..e56ca8d4a9 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -199,6 +199,14 @@ + + + + + + + + @@ -1745,6 +1753,15 @@ + + + + + + + + + @@ -1754,6 +1771,15 @@ + + + + + + + + + @@ -2678,6 +2704,15 @@ + + + + + + + + + @@ -2766,6 +2801,14 @@ + + + + + + + + diff --git a/cime_config/testdefs/testmods_dirs/cam/cam6_port_f09_rrtmgp/shell_commands b/cime_config/testdefs/testmods_dirs/cam/cam6_port_f09_rrtmgp/shell_commands new file mode 100644 index 0000000000..106897a2c6 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/cam6_port_f09_rrtmgp/shell_commands @@ -0,0 +1,3 @@ +./xmlchange --append CAM_CONFIG_OPTS="-rad rrtmgp" +./xmlchange ROF_NCPL=\$ATM_NCPL +./xmlchange GLC_NCPL=\$ATM_NCPL diff --git a/cime_config/testdefs/testmods_dirs/cam/cam6_port_f09_rrtmgp/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/cam6_port_f09_rrtmgp/user_nl_cam new file mode 100644 index 0000000000..fcbd0d438b --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/cam6_port_f09_rrtmgp/user_nl_cam @@ -0,0 +1,15 @@ + offline_driver_infile = '$DIN_LOC_ROOT/atm/cam/port/base_cam6_3mode_1deg.doubleCO2.cam.h1.0001-01-01-00000_c170526.nc' + rad_data_fdh = .true. + empty_htapes = .true. + avgflag_pertape = 'A','I' + fincl1 = 'SOLIN', 'QRS', 'FSNS', 'FSNT','FSNSC', 'FSDSC','FSNR','FLNR', + 'FSNTOA', 'FSUTOA', 'FSNTOAC', 'FSNTC', 'FSDSC', 'FSDS', 'SWCF', + 'QRL', 'FLNS', 'FLDS', 'FLNT', 'LWCF', 'FLUT' ,'FLUTC', 'FLNTC', + 'FLNSC', 'FLDSC' + fincl2 = 'SOLIN', 'QRS', 'FSNS', 'FSNT','FSNSC', 'FSDSC','FSNR','FLNR', + 'FSNTOA', 'FSUTOA', 'FSNTOAC', 'FSNTC', 'FSDSC', 'FSDS', 'SWCF', + 'QRL', 'FLNS', 'FLDS', 'FLNT', 'LWCF', 'FLUT' ,'FLUTC', 'FLNTC', + 'FLNSC', 'FLDSC' + rad_data_output = .false. + mfilt=100,100 + nhtfrq=-120,73 diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/shell_commands new file mode 100644 index 0000000000..106897a2c6 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/shell_commands @@ -0,0 +1,3 @@ +./xmlchange --append CAM_CONFIG_OPTS="-rad rrtmgp" +./xmlchange ROF_NCPL=\$ATM_NCPL +./xmlchange GLC_NCPL=\$ATM_NCPL diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/user_nl_cam new file mode 100644 index 0000000000..8482082dce --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/user_nl_cam @@ -0,0 +1,4 @@ +mfilt=1,1,1,1,1,1 +ndens=1,1,1,1,1,1 +nhtfrq=9,9,9,9,9,9 +inithist='ENDOFRUN' diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/user_nl_clm b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/user_nl_clm new file mode 100644 index 0000000000..0d83b5367b --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/user_nl_clm @@ -0,0 +1,27 @@ +!---------------------------------------------------------------------------------- +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value +! +! Include namelist variables for drv_flds_in ONLY if -megan and/or -drydep options +! are set in the CLM_NAMELIST_OPTS env variable. +! +! EXCEPTIONS: +! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting +! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting +! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting +! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting +! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting +! Set irrigate by the CLM_BLDNML_OPTS -irrig setting +! Set dtime with L_NCPL option +! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options +! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases +! (includes $inst_string for multi-ensemble cases) +! Set glc_grid with CISM_GRID option +! Set glc_smb with GLC_SMB option +! Set maxpatch_glcmec with GLC_NEC option +! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable +!---------------------------------------------------------------------------------- +hist_nhtfrq = 9 +hist_mfilt = 1 +hist_ndens = 1 + diff --git a/cime_config/usermods_dirs/rrtmgp/shell_commands b/cime_config/usermods_dirs/rrtmgp/shell_commands deleted file mode 100755 index 341f65a34e..0000000000 --- a/cime_config/usermods_dirs/rrtmgp/shell_commands +++ /dev/null @@ -1,7 +0,0 @@ -./xmlchange --force STOP_OPTION=ndays - -./xmlchange --force STOP_N=2 - -./xmlchange --append CAM_CONFIG_OPTS="--rad rrtmgp" - -./xmlchange DOUT_S=FALSE diff --git a/cime_config/usermods_dirs/rrtmgp/user_nl_cam b/cime_config/usermods_dirs/rrtmgp/user_nl_cam deleted file mode 100644 index e13d8e4865..0000000000 --- a/cime_config/usermods_dirs/rrtmgp/user_nl_cam +++ /dev/null @@ -1,11 +0,0 @@ -nhtfrq = 0,-3,1 -mfilt = 1,8,1 -ndens = 2,2,2 -history_budget = .true. -history_budget_histfile_num = 1 - -FINCL1 = 'FUS', 'FDS', 'FUL', 'FDL', 'FUSC', 'FDSC', 'FULC', 'FDLC', 'HR', 'QRSC', 'QRLC', 'TOT_CLD_VISTAU', 'TOT_ICLD_VISTAU', 'LIQ_ICLD_VISTAU', 'ICE_ICLD_VISTAU', 'SNOW_ICLD_VISTAU' - -FINCL2 = 'SOLIN','FSNT','FSNTC','FSNTOA','FSNTOAC','SWCF','LWCF','FLUT','FLUTC','PRECT','CLDTOT','CLDLOW','CLDHGH','TMQ','TGCLDLWP','TGCLDIWP','QRS','QRSC','QRL','QRLC' - -FINCL3 = 'T','Q','U','V','QRS','QRSC','QRL','QRLC','DTCOND','PTTEND','DTCORE','PRECT','LHFLX','SHFLX','FLUT','FLUTC','FSNT','FSNTC' diff --git a/cime_config/usermods_dirs/scam_rrtmgp/shell_commands b/cime_config/usermods_dirs/scam_rrtmgp/shell_commands deleted file mode 100755 index ff2497324b..0000000000 --- a/cime_config/usermods_dirs/scam_rrtmgp/shell_commands +++ /dev/null @@ -1,21 +0,0 @@ -./xmlchange --force MPILIB=mpi-serial - -./xmlchange --force REST_OPTION=never - -./xmlchange --force CLM_FORCE_COLDSTART=on - -./xmlchange --force PTS_LON=238.5 - -./xmlchange --force PTS_LAT=31.5 - -./xmlchange --force RUN_STARTDATE=1999-07-11 - -./xmlchange --force START_TOD=0 - -./xmlchange --force STOP_OPTION=nsteps - -./xmlchange --force STOP_N=144 - -./xmlchange --append CAM_CONFIG_OPTS="--rad rrtmgp" - -./xmlchange DOUT_S=FALSE diff --git a/cime_config/usermods_dirs/scam_rrtmgp/user_nl_cam b/cime_config/usermods_dirs/scam_rrtmgp/user_nl_cam deleted file mode 100644 index 57ebe708ed..0000000000 --- a/cime_config/usermods_dirs/scam_rrtmgp/user_nl_cam +++ /dev/null @@ -1,15 +0,0 @@ -iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/DYCOMSrf02_48hr_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc" -mfilt=2088 -nhtfrq=1 -scm_use_obs_uv = .true. -scm_use_obs_T =.true. -scm_relaxation = .true. -scm_relax_fincl = 'bc_a1', 'bc_a4', 'dst_a1', 'dst_a2', 'dst_a3', 'ncl_a1', 'ncl_a2', - 'ncl_a3', 'num_a1', 'num_a2', 'num_a3', - 'num_a4', 'pom_a1', 'pom_a4', 'so4_a1', 'so4_a2', 'so4_a3', 'soa_a1', 'soa_a2' -scm_relax_bot_p = 105000. -scm_relax_top_p = 200. -scm_relax_linear = .true. -scm_relax_tau_bot_sec = 864000. -scm_relax_tau_top_sec = 172800. diff --git a/doc/ChangeLog b/doc/ChangeLog index 4a2c43d13f..60c061a614 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,166 @@ =============================================================== +Tag name: +Originator(s): brianpm, courtneyp, eaton +Date: +One-line Summary: Provide RRTMGP as a radiation parameterization +Github PR URL: + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + +#255 - Provide RRTMGP as a radiation parameterization +https://github.com/ESCOMP/CAM/issues/255 + +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. + +Describe any changes made to the namelist: +. add variables rrtmgp_coefs_lw_file and rrtmgp_coefs_sw_file to contain + filepaths for the RRTMGP coefficients files. + +List any changes to the defaults for the boundary datasets: none + +Describe any substantial timing or memory changes: +. performance evaluation of RRTMGP has not yet been done. + +Code reviewed by: + +List all files eliminated: + +src/physics/rrtmg/cloud_rad_props.F90 +src/physics/rrtmg/ebert_curry.F90 +src/physics/rrtmg/oldcloud.F90 +src/physics/rrtmg/slingo.F90 +. these cloud optics files which can be shared by rrtmg and rrtmgp are + moved to src/physics/cam + +List all files added and what they do: + +bld/namelist_files/use_cases/1850_cam5.xml +. use case file for 1850 cam5 physics + +cime_config/testdefs/testmods_dirs/cam/cam6_port_f09_rrtmgp/shell_commands +cime_config/testdefs/testmods_dirs/cam/cam6_port_f09_rrtmgp/user_nl_cam +cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/shell_commands +cime_config/testdefs/testmods_dirs/cam/outfrq9s_rrtmgp/user_nl_cam +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/rrtmgp/mcica_subcol_gen.F90 +src/physics/rrtmgp/radconstants.F90 +src/physics/rrtmgp/radiation.F90 +src/physics/rrtmgp/rrtmgp_inputs.F90 +. CAM interface code for RRTMGP. + +List all existing files that have been modified, and describe the changes: + +.gitignore +. add directories src/physics/rrtmgp/{data,ext} + +Externals_CAM.cfg +. add external definition for rte-rrtmgp source +. add external definition for rrtmgp data + +bld/build-namelist +. set the correct filepaths for the coefficient datasets which are checked + out in the source code directory tree. +. generalize logic to include both rrtmgp and rrtmg when appropriate +. add error check for old cloud optics no longer supported + +bld/config_files/definition.xml +. add 'rrtmgp' as valid value for 'rad' configure option + +bld/configure +. add rrtmgp and rrtmgp_gpu as valid values for '-rad' argument. +. '-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. + +bld/namelist_files/namelist_defaults_cam.xml +. the aersol and cloud optics datasets for RRTMG are being reused for + RRTMGP for now + +bld/namelist_files/namelist_definition.xml +. add 'rrtmgp' as valid value for 'radiation_scheme' +. 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) +. 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.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_rrtmgp + SMS_Ld5.f09_f09_mg17.PC6.izumi_gnu.cam-cam6_port_f09_rrtmgp + +src/chemistry/utils/solar_data.F90 +. add solar_htng_spctrl_scl to log file output + +src/physics/cam/aer_rad_props.F90 +. nrh, ot_length now accessed from phys_prop + +src/physics/cam/aerosol_optics_cam.F90 +. ot_length now accessed from phys_prop + +src/physics/cam/phys_prop.F90 +. add the public parameter nrh to this module. Was previously in + radconstants. +. turn off old debug output to log file + +src/physics/cam/physpkg.F90 +. reorder initialization of solar_data and radiation modules to allow + reading the spectral band boundaries from the input data rather than + requiring them to be hardcoded. + +src/physics/cam/rad_constituents.F90 +. access ot_length from phys_prop rather than rad_constituents + +src/physics/cam_dev/physpkg.F90 +. reorder initialization of solar_data and radiation modules to allow + reading the wavenumber band boundaries from the input data rather than + requiring them to be hardcoded. + +src/physics/camrt/radconstants.F90 +. parameters ot_length and nrh moved to phys_props + +src/physics/rrtmg/radconstants.F90 +. parameters ot_length and nrh moved to phys_props + +src/physics/simple/radconstants.F90 +. parameters ot_length and nrh moved to phys_props +. add dummy interface for get_sw_spectral_boundaries + +src/physics/spcam/crm/CLUBB/crmx_mt95.f90 +. removed 3 non-ascii characters (in comments) + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +cheyenne/intel/aux_cam: + +izumi/nag/aux_cam: + +izumi/gnu/aux_cam: + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers: None. + New RRTMGP option changes answers only when enabled. + +=============================================================== +=============================================================== + Tag name: cam6_3_133 Originator(s): fvitt Date: 19 Oct 2023 diff --git a/src/physics/cam/phys_prop.F90 b/src/physics/cam/phys_prop.F90 index ecbf6f85e0..6c504e8c78 100644 --- a/src/physics/cam/phys_prop.F90 +++ b/src/physics/cam/phys_prop.F90 @@ -1111,9 +1111,7 @@ subroutine bulk_props_init(physprop, nc_id) type(var_desc_T) :: vid - ! ***N.B.*** RRTMGP hasn't set the value of idx_sw_diag when this routine is - ! called. The debug option will need to be modified for RRTMGP. - logical :: debug = .true. + logical :: debug = .false. character(len=*), parameter :: subname = 'bulk_props_init' !------------------------------------------------------------------------------------ diff --git a/src/physics/spcam/crm/CLUBB/crmx_mt95.f90 b/src/physics/spcam/crm/CLUBB/crmx_mt95.f90 index 14d75bc733..7c2ff7d9db 100644 --- a/src/physics/spcam/crm/CLUBB/crmx_mt95.f90 +++ b/src/physics/spcam/crm/CLUBB/crmx_mt95.f90 @@ -1,10 +1,10 @@ ! A C-program for MT19937, with initialization improved 2002/1/26. ! Coded by Takuji Nishimura and Makoto Matsumoto. -! Code converted to Fortran 95 by José Rui Faustino de Sousa +! Code converted to Fortran 95 by Jose Rui Faustino de Sousa ! Date: 2002-02-01 -! Enhanced version by José Rui Faustino de Sousa +! Enhanced version by Jose Rui Faustino de Sousa ! Date: 2003-04-30 ! Interface: @@ -1310,7 +1310,7 @@ subroutine genrand_res53_7d( r ) end subroutine genrand_res53_7d ! These real versions are due to Isaku Wada, 2002/01/09 added - ! Altered by José Sousa genrand_real[1-3] will not return exactely + ! Altered by Jose Sousa genrand_real[1-3] will not return exactely ! the same values but should have the same properties and are faster end module crmx_mt95 From f1cfe38deb758cd637c1d4702ca606b35a293ae4 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 25 Oct 2023 13:33:01 -0400 Subject: [PATCH 45/53] fix tests --- cime_config/testdefs/testlist_cam.xml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index e56ca8d4a9..a51e1324d1 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -201,7 +201,7 @@ - + @@ -2704,9 +2704,8 @@ - + - From fd8fa8e6141cf983d806adcc95e2d18620544195 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 24 Jan 2024 10:19:25 -0500 Subject: [PATCH 46/53] update RRTMGP externals --- Externals_CAM.cfg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 3e929fcbbb..fe5f6364b1 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -83,14 +83,14 @@ externals = Externals_HCO.cfg local_path = src/physics/rrtmgp/ext protocol = git repo_url = https://github.com/earth-system-radiation/rte-rrtmgp.git -hash = a1b6781 +tag = v1.7 required = True [rrtmgp-data] local_path = src/physics/rrtmgp/data protocol = git repo_url = https://github.com/earth-system-radiation/rrtmgp-data.git -tag = v1.7.1 +tag = v1.8 required = True [externals_description] From a3571bc819dfe8cb40e5e8a80b23a41e79e7a5fd Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 31 Jan 2024 19:38:48 -0500 Subject: [PATCH 47/53] address review comments --- bld/configure | 5 + cime_config/testdefs/testlist_cam.xml | 15 +- doc/ChangeLog | 34 ++- src/physics/cam/cloud_rad_props.F90 | 30 +-- ...t_curry.F90 => ebert_curry_ice_optics.F90} | 4 +- .../cam/{oldcloud.F90 => oldcloud_optics.F90} | 30 +-- .../cam/{slingo.F90 => slingo_liq_optics.F90} | 4 +- src/physics/rrtmg/radiation.F90 | 4 +- src/physics/rrtmgp/mcica_subcol_gen.F90 | 2 - src/physics/rrtmgp/radconstants.F90 | 20 +- src/physics/rrtmgp/radiation.F90 | 214 ++++++++++++------ 11 files changed, 230 insertions(+), 132 deletions(-) rename src/physics/cam/{ebert_curry.F90 => ebert_curry_ice_optics.F90} (99%) rename src/physics/cam/{oldcloud.F90 => oldcloud_optics.F90} (94%) rename src/physics/cam/{slingo.F90 => slingo_liq_optics.F90} (99%) 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 From ccb49739c8ca84ea22802ebd720d88e7185e33d8 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 6 Feb 2024 10:13:19 -0500 Subject: [PATCH 48/53] use broadband flux objects for clear-sky calcs --- src/physics/rrtmgp/radiation.F90 | 129 ++++++++++++++------------- src/physics/rrtmgp/rrtmgp_inputs.F90 | 4 +- 2 files changed, 71 insertions(+), 62 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index d1b5603301..099eaeae3c 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -52,6 +52,7 @@ module radiation use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str use mo_source_functions, only: ty_source_func_lw +use mo_fluxes, only: ty_fluxes_broadband use mo_fluxes_byband, only: ty_fluxes_byband use string_utils, only: to_lower @@ -955,10 +956,13 @@ subroutine radiation_tend( & type(ty_optical_props_1scl) :: aer_lw type(ty_optical_props_2str) :: aer_sw - ! Flux objects contain all fluxes computed by RRTMGP. Includes spectrally resolved and - ! total fluxes for all levels of the RRTMGP grid. - type(ty_fluxes_byband) :: fsw, fswc - type(ty_fluxes_byband) :: flw, flwc + ! Flux objects contain all fluxes computed by RRTMGP. + ! SW allsky fluxes always include spectrally resolved fluxes needed for surface models. + type(ty_fluxes_byband) :: fsw + ! LW allsky fluxes only need spectrally resolved fluxes when spectralflux=.true. + type(ty_fluxes_byband) :: flw + ! Only broadband fluxes needed for clear sky (diagnostics). + type(ty_fluxes_broadband) :: fswc, flwc ! Arrays for output diagnostics on CAM grid. real(r8) :: fns(pcols,pverp) ! net shortwave flux @@ -1758,8 +1762,8 @@ subroutine coefs_init(coefs_file, available_gases, kdist) class(ty_gas_optics_rrtmgp), intent(out) :: kdist ! local variables - type(file_desc_t) :: fh ! pio file handle - character(len=256) :: locfn ! path to file on local storage + type(file_desc_t) :: fh ! pio file handle + character(len=cl) :: locfn ! path to file on local storage ! File dimensions integer :: & @@ -2124,9 +2128,10 @@ subroutine coefs_init(coefs_file, available_gases, kdist) 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 + ! Read as integer and convert to logical 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) @@ -2140,29 +2145,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) minor_scales_with_density_lower(i) = .true. end if end do - deallocate(int2log) - - ! Read as integer and convert to logical - 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) - if (ierr /= PIO_NOERR) call endrun(sub//': error reading minor_scales_with_density_upper') - do i = 1,minor_absorber_intervals_upper - if (int2log(i) .eq. 0) then - minor_scales_with_density_upper(i) = .false. - else - minor_scales_with_density_upper(i) = .true. - end if - end do - deallocate(int2log) - ! Read as integer and convert to logical - 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) @@ -2176,11 +2159,27 @@ subroutine coefs_init(coefs_file, available_gases, kdist) scale_by_complement_lower(i) = .true. end if end do + deallocate(int2log) ! Read as integer and convert to logical 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) + if (ierr /= PIO_NOERR) call endrun(sub//': error reading minor_scales_with_density_upper') + do i = 1,minor_absorber_intervals_upper + if (int2log(i) .eq. 0) then + minor_scales_with_density_upper(i) = .false. + else + minor_scales_with_density_upper(i) = .true. + end if + end do + 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) @@ -2194,6 +2193,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) scale_by_complement_upper(i) = .true. end if end do + deallocate(int2log) allocate(scaling_gas_lower(minor_absorber_intervals_lower), stat=istat) @@ -2307,9 +2307,9 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct) ! Allocate flux arrays and set values to zero. ! Arguments - integer, intent(in) :: ncol, nlevels, nbands - type(ty_fluxes_byband), intent(inout) :: fluxes - logical, intent(in), optional :: do_direct + integer, intent(in) :: ncol, nlevels, nbands + class(ty_fluxes_broadband), intent(inout) :: fluxes + logical, optional, intent(in) :: do_direct ! Local variables logical :: do_direct_local @@ -2335,17 +2335,23 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, fluxes, do_direct) call check_allocate(istat, sub, 'fluxes%flux_dn_dir') end if - ! Fluxes by band - 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 + select type (fluxes) + type is (ty_fluxes_byband) + ! Fluxes by band always needed for SW. Only allocate for LW + ! 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') + 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 + end if + end select ! Initialize call reset_fluxes(fluxes) @@ -2358,24 +2364,23 @@ subroutine reset_fluxes(fluxes) ! Reset flux arrays to zero. - type(ty_fluxes_byband), intent(inout) :: fluxes + class(ty_fluxes_broadband), intent(inout) :: fluxes !---------------------------------------------------------------------------- ! Reset broadband fluxes fluxes%flux_up(:,:) = 0._r8 fluxes%flux_dn(:,:) = 0._r8 fluxes%flux_net(:,:) = 0._r8 - if (associated(fluxes%flux_dn_dir)) then - fluxes%flux_dn_dir(:,:) = 0._r8 - end if - - ! Reset band-by-band fluxes - fluxes%bnd_flux_up(:,:,:) = 0._r8 - fluxes%bnd_flux_dn(:,:,:) = 0._r8 - fluxes%bnd_flux_net(:,:,:) = 0._r8 - if (associated(fluxes%bnd_flux_dn_dir)) then - fluxes%bnd_flux_dn_dir(:,:,:) = 0._r8 - end if + if (associated(fluxes%flux_dn_dir)) fluxes%flux_dn_dir(:,:) = 0._r8 + + select type (fluxes) + type is (ty_fluxes_byband) + ! Reset band-by-band fluxes + if (associated(fluxes%bnd_flux_up)) fluxes%bnd_flux_up(:,:,:) = 0._r8 + if (associated(fluxes%bnd_flux_dn)) fluxes%bnd_flux_dn(:,:,:) = 0._r8 + if (associated(fluxes%bnd_flux_net)) fluxes%bnd_flux_net(:,:,:) = 0._r8 + if (associated(fluxes%bnd_flux_dn_dir)) fluxes%bnd_flux_dn_dir(:,:,:) = 0._r8 + end select end subroutine reset_fluxes @@ -2407,16 +2412,20 @@ end subroutine free_optics_lw subroutine free_fluxes(fluxes) - type(ty_fluxes_byband), intent(inout) :: fluxes + class(ty_fluxes_broadband), intent(inout) :: fluxes if (associated(fluxes%flux_up)) deallocate(fluxes%flux_up) if (associated(fluxes%flux_dn)) deallocate(fluxes%flux_dn) if (associated(fluxes%flux_net)) deallocate(fluxes%flux_net) if (associated(fluxes%flux_dn_dir)) deallocate(fluxes%flux_dn_dir) - if (associated(fluxes%bnd_flux_up)) deallocate(fluxes%bnd_flux_up) - if (associated(fluxes%bnd_flux_dn)) deallocate(fluxes%bnd_flux_dn) - if (associated(fluxes%bnd_flux_net)) deallocate(fluxes%bnd_flux_net) - if (associated(fluxes%bnd_flux_dn_dir)) deallocate(fluxes%bnd_flux_dn_dir) + + select type (fluxes) + type is (ty_fluxes_byband) + if (associated(fluxes%bnd_flux_up)) deallocate(fluxes%bnd_flux_up) + if (associated(fluxes%bnd_flux_dn)) deallocate(fluxes%bnd_flux_dn) + if (associated(fluxes%bnd_flux_net)) deallocate(fluxes%bnd_flux_net) + if (associated(fluxes%bnd_flux_dn_dir)) deallocate(fluxes%bnd_flux_dn_dir) + end select end subroutine free_fluxes diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 93b32b007f..9aaab0f518 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -206,8 +206,8 @@ subroutine rrtmgp_set_state( & ! the albedo to be the average of the visible and near-infrared ! broadband albedos do i = 1, nday - alb_dir(iband,i) = 0.5 * (cam_in%aldir(idxday(i)) + cam_in%asdir(idxday(i))) - alb_dif(iband,i) = 0.5 * (cam_in%aldif(idxday(i)) + cam_in%asdif(idxday(i))) + alb_dir(iband,i) = 0.5_r8 * (cam_in%aldir(idxday(i)) + cam_in%asdir(idxday(i))) + alb_dif(iband,i) = 0.5_r8 * (cam_in%aldif(idxday(i)) + cam_in%asdif(idxday(i))) end do end if end do From 0ac117364976e955f497189c153f325f00c54ba3 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 6 Feb 2024 13:00:22 -0500 Subject: [PATCH 49/53] address review comments --- doc/ChangeLog | 3 +++ src/physics/rrtmgp/rrtmgp_inputs.F90 | 34 +++++++++++++++------------- test/system/TR8.sh | 4 ++++ 3 files changed, 25 insertions(+), 16 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 3c6f232433..fce0eb29da 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -157,6 +157,9 @@ src/physics/simple/radconstants.F90 src/physics/spcam/crm/CLUBB/crmx_mt95.f90 . removed 3 non-ascii characters (in comments) +test/system/TR8.sh +. add checks for rrtmgp interface code + If there were any failures reported from running test_driver.sh on any test platform, and checkin with these failures has been OK'd by the gatekeeper, then copy the lines from the td.*.status files for the failed tests to the diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 9aaab0f518..179b7b7f9b 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -39,6 +39,7 @@ module rrtmgp_inputs use cam_history_support, only: fillvalue use cam_logfile, only: iulog use cam_abortutils, only: endrun +use error_messages, only: alloc_err implicit none private @@ -230,7 +231,7 @@ end subroutine rrtmgp_set_state !========================================================================================= -logical function is_visible(wavenumber) +pure logical function is_visible(wavenumber) ! Wavenumber is in the visible if it is above the visible threshold ! wavenumber, and in the infrared if it is below the threshold @@ -315,6 +316,7 @@ subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, ga ! Local variables integer :: i, idx(numactivecols) + integer :: istat real(r8), pointer :: gas_mmr(:,:) real(r8), allocatable :: gas_vmr(:,:) real(r8), allocatable :: mmr(:,:) @@ -341,8 +343,10 @@ subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, ga call rad_cnst_get_gas(icall, gas_name, state, pbuf, gas_mmr) ! Copy into storage for RRTMGP - allocate(mmr(numactivecols, nlay)) - allocate(gas_vmr(numactivecols, nlay)) + allocate(mmr(numactivecols, nlay), stat=istat) + call alloc_err(istat, sub, 'mmr', numactivecols*nlay) + allocate(gas_vmr(numactivecols, nlay), stat=istat) + call alloc_err(istat, sub, 'gas_vmr', numactivecols*nlay) do i = 1, numactivecols mmr(i,ktoprad:) = gas_mmr(idx(i),ktopcam:) @@ -370,12 +374,10 @@ subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, ga ! to produce temperatures at the top of CAM that are most consistent with WACCM at similar pressure levels. if ((gas_name == 'O3') .and. (nlay == pverp)) then + P_top = 50.0_r8 do i = 1, numactivecols - P_top = 50.0_r8 P_int = state%pint(idx(i),1) ! pressure (Pa) at upper interface of CAM P_mid = state%pmid(idx(i),1) ! pressure (Pa) at midpoint of top layer of CAM - alpha = 0.0_r8 - beta = 0.0_r8 alpha = log(P_int/P_top) beta = log(P_mid/P_int)/log(P_mid/P_top) @@ -387,8 +389,6 @@ subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, ga chi_0 = chi_mid / (1._r8 + beta) chi_eff = chi_0 * (a + b) gas_vmr(i,1) = chi_eff - chi_eff = chi_eff * P_int / massratio / 9.8_r8 ! O3 column above in kg m-2 - chi_eff = chi_eff / 2.1415e-5_r8 ! O3 column above in DU end if end do end if @@ -489,7 +489,7 @@ subroutine rrtmgp_set_cloud_lw( & type(ty_optical_props_1scl), intent(out) :: cloud_lw ! Diagnostic outputs - real(r8), intent(out) :: cld_lw_abs_cloudsim(pcols,pver) ! in-cloud snow optical depth (for COSP) + real(r8), intent(out) :: cld_lw_abs_cloudsim(pcols,pver) ! in-cloud liq+ice optical depth (for COSP) real(r8), intent(out) :: snow_lw_abs_cloudsim(pcols,pver)! in-cloud snow optical depth (for COSP) real(r8), intent(out) :: grau_lw_abs_cloudsim(pcols,pver)! in-cloud Graupel optical depth (for COSP) @@ -645,27 +645,28 @@ subroutine rrtmgp_set_cloud_sw( & integer :: i, k, ncol integer :: igpt, nver + integer :: istat integer, parameter :: changeseed = 1 ! 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) :: 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) :: 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) :: 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) :: 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) :: 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 ! RRTMGP does not use this property in its 2-stream calculations. real(r8) :: sw_tau_w_f(nswbands,pcols,pver) ! Forward scattered fraction * tau * w. @@ -806,7 +807,8 @@ subroutine rrtmgp_set_cloud_sw( & day_cld_tau_w_g(nswbands,nday,nver), & tauc(nswbands,nday,nver), taucmcl(nswgpts,nday,nver), & ssac(nswbands,nday,nver), ssacmcl(nswgpts,nday,nver), & - asmc(nswbands,nday,nver), asmcmcl(nswgpts,nday,nver) ) + asmc(nswbands,nday,nver), asmcmcl(nswgpts,nday,nver), stat=istat) + call alloc_err(istat, sub, 'cldf,..,asmcmcl', 9*nswgpts*nday*nver) ! Subset "chunk" data so just the daylight columns, and the number of CAM layers in the ! radiation calculation are used by MCICA to produce subcolumns. diff --git a/test/system/TR8.sh b/test/system/TR8.sh index e107c702d3..b4eb0365d7 100755 --- a/test/system/TR8.sh +++ b/test/system/TR8.sh @@ -12,6 +12,8 @@ ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/physics/camrt rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/physics/rrtmg -s aer_src rc=`expr $? + $rc` +ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/physics/rrtmgp -s data,ext +rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/physics/simple rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/components/cam/src/physics/waccm @@ -27,6 +29,8 @@ ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/camrt rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/rrtmg -s aer_src rc=`expr $? + $rc` +ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/rrtmgp -s data,ext +rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/simple rc=`expr $? + $rc` ruby $ADDREALKIND_EXE -r r8 -l 1 -d $CAM_ROOT/src/physics/waccm From e6f1f709bce92c5b7492f5fd173eedd253d35571 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 6 Feb 2024 20:32:39 -0500 Subject: [PATCH 50/53] fix filename in namelist defaults file --- bld/namelist_files/namelist_defaults_cam.xml | 2 +- src/physics/rrtmgp/rrtmgp_inputs.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 1fb2be793c..5afa8a0155 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -1993,7 +1993,7 @@ OFF -atm/cam/chem/trop_mam/atmsrf_ne3np4.pg3_c221214.nc +atm/cam/chem/trop_mam/atmsrf_ne3np4.pg3_221214.nc atm/cam/chem/trop_mam/atmsrf_ne5np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne5pg3_201105.nc atm/cam/chem/trop_mam/atmsrf_ne16np4_110920.nc diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 179b7b7f9b..2f2b125e09 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -705,7 +705,7 @@ subroutine rrtmgp_set_cloud_sw( & call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, sw_tau_w_f) do i = 1, ncol do k = 1, pver - if (cldfprime(i,k) > 0.) then + if (cldfprime(i,k) > 0._r8) then c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & From 29da94d36769ec616148741650ca9a9d8a35b43b Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Tue, 13 Feb 2024 09:40:47 -0500 Subject: [PATCH 51/53] 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 From 02abc17857e996b652a24f3ab15d85f9a440d197 Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Mon, 19 Feb 2024 19:21:39 -0500 Subject: [PATCH 52/53] address review comments --- cime_config/testdefs/testlist_cam.xml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 73ec42ee96..62cd0af626 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1805,7 +1805,7 @@ - + @@ -2785,7 +2785,7 @@ - + From 538a35673ef1f1a3b374f0cf10ca93c6b2a4b7dc Mon Sep 17 00:00:00 2001 From: Brian Eaton Date: Wed, 21 Feb 2024 13:55:37 -0500 Subject: [PATCH 53/53] update ChangeLog --- doc/ChangeLog | 33 +++++++++++++++++++++++++++------ 1 file changed, 27 insertions(+), 6 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 8fbe06f141..5ea328d2c8 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,8 +1,8 @@ =============================================================== -Tag name: +Tag name: cam6_3_148 Originator(s): brianpm, courtneyp, eaton -Date: +Date: Wed 21 Feb 2024 One-line Summary: Provide RRTMGP as a radiation parameterization Github PR URL: https://github.com/ESCOMP/CAM/pull/909 @@ -16,7 +16,6 @@ Miscellaneous: 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. @@ -30,7 +29,7 @@ List any changes to the defaults for the boundary datasets: none Describe any substantial timing or memory changes: . performance evaluation of RRTMGP has not yet been done. -Code reviewed by: +Code reviewed by: nusbaume, cacraigucar, sjsprecious List all files eliminated: @@ -165,14 +164,36 @@ platform, and checkin with these failures has been OK'd by the gatekeeper, then copy the lines from the td.*.status files for the failed tests to the appropriate machine below. All failed tests must be justified. -cheyenne/intel/aux_cam: - derecho/intel/aux_cam: + ERP_Ln9_Vnuopc.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: PEND) details: + ERP_Ln9_Vnuopc.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + SMS_Ld1_Vnuopc.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: PEND) details: +-- pre-existing failures + + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + FAIL ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp NLCOMP + FAIL ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp BASELINE /glade/campaign/cesm/community/amwg/cam_baselines/cam6_3_147: ERROR BFAIL baseline directory '/glade/campaign/cesm/community/amwg/cam_baselines/cam6_3_147/ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp' does not exist + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + FAIL SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp NLCOMP + FAIL SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp BASELINE /glade/campaign/cesm/community/amwg/cam_baselines/cam6_3_147: ERROR BFAIL baseline directory '/glade/campaign/cesm/community/amwg/cam_baselines/cam6_3_147/SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp' does not exist +-- expected diffs - no baselines for new tests + izumi/nag/aux_cam: + DAE_Vnuopc.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: +-- pre-existing failure + izumi/gnu/aux_cam: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + FAIL ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp NLCOMP + FAIL ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp BASELINE /fs/cgd/csm/models/atm/cam/pretag_bl/cam6_3_147_gnu: ERROR BFAIL baseline directory '/fs/cgd/csm/models/atm/cam/pretag_bl/cam6_3_147_gnu/ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp' does not exist + SMS_Ld5.f09_f09_mg17.PC6.izumi_gnu.cam-cam6_port_f09_rrtmgp (Overall: DIFF) details: + FAIL SMS_Ld5.f09_f09_mg17.PC6.izumi_gnu.cam-cam6_port_f09_rrtmgp NLCOMP + FAIL SMS_Ld5.f09_f09_mg17.PC6.izumi_gnu.cam-cam6_port_f09_rrtmgp BASELINE /fs/cgd/csm/models/atm/cam/pretag_bl/cam6_3_147_gnu: ERROR BFAIL baseline directory '/fs/cgd/csm/models/atm/cam/pretag_bl/cam6_3_147_gnu/SMS_Ld5.f09_f09_mg17.PC6.izumi_gnu.cam-cam6_port_f09_rrtmgp' does not exist +-- expected diffs - no baselines for new tests + CAM tag used for the baseline comparison tests if different than previous tag: