From 247774ecc307360ea9d9f48a6565f4bccf48a3ef Mon Sep 17 00:00:00 2001 From: peverwhee Date: Mon, 10 Feb 2025 09:47:37 -0700 Subject: [PATCH 01/17] use ccppized init --- src/physics/rrtmgp/radconstants.F90 | 69 +- src/physics/rrtmgp/radiation.F90 | 199 ++- src/physics/rrtmgp/radiation_utils.F90 | 156 ++ src/physics/rrtmgp/rrtmgp_inputs.F90 | 1652 +++++++++------------- src/physics/rrtmgp/rrtmgp_inputs_cam.F90 | 1056 ++++++++++++++ src/utils/cam_ccpp/machine.F90 | 12 + 6 files changed, 2059 insertions(+), 1085 deletions(-) create mode 100644 src/physics/rrtmgp/radiation_utils.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_inputs_cam.F90 create mode 100644 src/utils/cam_ccpp/machine.F90 diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index f490b81b7b..4135a6addf 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -6,6 +6,8 @@ module radconstants use shr_kind_mod, only: r8 => shr_kind_r8 use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use cam_abortutils, only: endrun +use radiation_utils, only: get_sw_spectral_boundaries_ccpp +use radiation_utils, only: get_lw_spectral_boundaries_ccpp implicit none private @@ -24,7 +26,7 @@ module radconstants real(r8), target :: wavenumber_low_longwave(nlwbands) real(r8), target :: wavenumber_high_longwave(nlwbands) -logical :: wavenumber_boundaries_set = .false. +logical :: wavenumber_boundaries_set = .true. integer, public, protected :: nswgpts ! number of SW g-points integer, public, protected :: nlwgpts ! number of LW g-points @@ -131,41 +133,24 @@ end subroutine set_wavenumber_bands !========================================================================================= -subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) + 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), dimension(:), intent(out) :: low_boundaries + real(r8), dimension(:), intent(out) :: high_boundaries character(*), intent(in) :: units ! requested units - character(len=*), parameter :: sub = 'get_sw_spectral_boundaries' + character(len=512) :: errmsg + integer :: errflg !---------------------------------------------------------------------------- - if (.not. wavenumber_boundaries_set) then - call endrun(sub//': ERROR, wavenumber boundaries not set. ') + call get_sw_spectral_boundaries_ccpp(low_boundaries, high_boundaries, units, errmsg, errflg) + if (errflg /= 0) then + call endrun(errmsg) end if - 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(sub//': ERROR, requested spectral units not recognized: '//units) - end select - -end subroutine get_sw_spectral_boundaries + end subroutine get_sw_spectral_boundaries !========================================================================================= @@ -176,35 +161,17 @@ 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' + character(len=512) :: errmsg + integer :: errflg !---------------------------------------------------------------------------- - if (.not. wavenumber_boundaries_set) then - call endrun(sub//': ERROR, wavenumber boundaries not set. ') + call get_lw_spectral_boundaries_ccpp(low_boundaries, high_boundaries, units, errmsg, errflg) + if (errflg /= 0) then + call endrun(errmsg) end if - 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(sub//': ERROR, requested spectral units not recognized: '//units) - end select - end subroutine get_lw_spectral_boundaries - + !========================================================================================= integer function rad_gas_index(gasname) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index bb1667b0ec..7edf1e61f4 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -15,7 +15,7 @@ module radiation 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 physconst, only: cappa, cpair, gravit, stebol use solar_irrad_data, only: sol_tsi use time_manager, only: get_nstep, is_first_step, is_first_restart_step, & @@ -23,10 +23,8 @@ module radiation 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: nradgas, gasnamelength, gaslist, nswbands, nlwbands, & - nswgpts, set_wavenumber_bands +use radconstants, only: nradgas, gasnamelength, nswbands, nlwbands, & + gaslist use cloud_rad_props, only: cloud_rad_props_init @@ -151,6 +149,15 @@ 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 +! 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) = 0 ! chunk indices of daylight columns +integer :: idxnite(pcols)= 0 ! chunk indices of night columns +real(r8) :: coszrs(pcols) ! Cosine solar zenith angle +real(r8) :: eccf ! Earth orbit eccentricity factor + ! 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) @@ -180,6 +187,8 @@ module radiation ! Number of layers in radiation calculations. integer :: nlay +! Number of interfaces in radiation calculations. +integer :: nlayp ! 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. @@ -200,6 +209,24 @@ 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. +integer :: nlwgpts +integer :: nswgpts + +! Band indices for bands containing specific wavelengths +integer :: idx_sw_diag +integer :: idx_nir_diag +integer :: idx_uv_diag +integer :: idx_sw_cloudsim +integer :: idx_lw_diag +integer :: idx_lw_cloudsim + +real(r8) :: sw_low_bounds(nswbands) +real(r8) :: sw_high_bounds(nswbands) + +! Flag to perform shortwave or longwave on current timestep +logical :: dosw +logical :: dolw + ! 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 @@ -420,6 +447,8 @@ end function radiation_nextsw_cday !================================================================================================ subroutine radiation_init(pbuf2d) + use rrtmgp_inputs, only: rrtmgp_inputs_init + use rrtmgp_inputs_cam, only: rrtmgp_inputs_cam_init ! Initialize the radiation and cloud optics. ! Add fields to the history buffer. @@ -428,12 +457,16 @@ subroutine radiation_init(pbuf2d) type(physics_buffer_desc), pointer :: pbuf2d(:,:) ! local variables - character(len=128) :: errmsg + character(len=512) :: errmsg ! names of gases that are available in the model ! -- needed for the kdist initialization routines type(ty_gas_concs) :: available_gases + real(r8) :: sw_low_bounds(nswbands) + real(r8) :: lw_low_bounds(nswbands) + real(r8) :: qrl_unused(1,1) + integer :: i, icall integer :: nstep ! current timestep number logical :: history_amwg ! output the variables used by the AMWG diag package @@ -442,42 +475,13 @@ 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, istat + integer :: ierr, istat, errflg integer :: dtime character(len=*), parameter :: sub = 'radiation_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) - - 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 - nlaycam = pver - else if (nlay == (pverp-1)) then - ! Special case nlay == (pverp-1) -- topmost interface outside bounds (CAM MT config), treat as if it is ok. - ktopcam = 1 - ktoprad = 2 - nlaycam = pver - nlay = nlay+1 ! reassign the value so later code understands to treat this case like nlay==pverp - write(iulog,*) 'RADIATION_INIT: Special case of 1 model interface at p < 1Pa. Top layer will be INCLUDED in radiation calculation.' - write(iulog,*) 'RADIATION_INIT: nlay = ',nlay, ' same as pverp: ',nlay==pverp - else - ! nlay < pverp. nlay layers are used in radiation calcs, and they are - ! all CAM layers. - ktopcam = pver - nlay + 1 - ktoprad = 1 - nlaycam = nlay - end if - ! 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. @@ -492,12 +496,30 @@ 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. 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. - call rrtmgp_inputs_init(ktopcam, ktoprad) + ! Set up inputs to RRTMGP + call rrtmgp_inputs_init(ktopcam, ktoprad, nlaycam, sw_low_bounds, sw_high_bounds, nswbands, & + pref_edge, nlay, pver, pverp, kdist_sw, kdist_lw, qrl_unused, is_first_step(), use_rad_dt_cosz, & + get_step_size(), get_nstep(), iradsw, dt_avg, irad_always, is_first_restart_step(), & + nlwbands, nradgas, gasnamelength, iulog, idx_sw_diag, idx_nir_diag, idx_uv_diag, & + idx_sw_cloudsim, idx_lw_diag, idx_lw_cloudsim, gaslist, nswgpts, nlwgpts, nlayp, & + nextsw_cday, get_curr_calday(), errmsg, errflg) + write(iulog,*) 'peverwhee - after init' + write(iulog,*) ktopcam + write(iulog,*) ktoprad + write(iulog,*) sw_low_bounds + write(iulog,*) sw_high_bounds + write(iulog,*) nswbands + write(iulog,*) idx_sw_diag + write(iulog,*) idx_nir_diag + write(iulog,*) idx_uv_diag + write(iulog,*) idx_sw_cloudsim + write(iulog,*) idx_lw_diag + write(iulog,*) idx_lw_cloudsim + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if + call rrtmgp_inputs_cam_init(ktopcam, ktoprad, idx_sw_diag, idx_nir_diag, idx_uv_diag, idx_sw_cloudsim, idx_lw_diag, & + idx_lw_cloudsim) ! initialize output fields for offline driver call rad_data_init(pbuf2d) @@ -836,9 +858,11 @@ subroutine radiation_tend( & use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz - use rrtmgp_inputs, only: rrtmgp_set_state, rrtmgp_set_gases_lw, rrtmgp_set_cloud_lw, & + use rrtmgp_inputs, only: rrtmgp_inputs_timestep_init, rrtmgp_inputs_run + + use rrtmgp_inputs_cam, only: rrtmgp_set_gases_lw, rrtmgp_set_cloud_lw, & rrtmgp_set_aer_lw, rrtmgp_set_gases_sw, rrtmgp_set_cloud_sw, & - rrtmgp_set_aer_sw + rrtmgp_set_aer_sw, rrtmgp_set_state ! RRTMGP drivers for flux calculations. use mo_rte_lw, only: rte_lw @@ -881,13 +905,6 @@ subroutine radiation_tend( & 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) ! chunk indices of daylight columns - integer :: IdxNite(pcols) ! chunk indices of night columns - integer :: itim_old real(r8), pointer :: cld(:,:) ! cloud fraction @@ -986,6 +1003,7 @@ subroutine radiation_tend( & real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables character(len=128) :: errmsg + integer :: errflg character(len=*), parameter :: sub = 'radiation_tend' !-------------------------------------------------------------------------------------- @@ -1025,17 +1043,25 @@ subroutine radiation_tend( & end if ! Gather night/day column indices. - Nday = 0 - Nnite = 0 + nday = 0 + nnite = 0 + idxday = 0 + idxnite = 0 do i = 1, ncol if ( coszrs(i) > 0.0_r8 ) then - Nday = Nday + 1 - IdxDay(Nday) = i + nday = nday + 1 + idxday(nday) = i + write(iulog,*) 'peverwhee - adding new daylight point' else - Nnite = Nnite + 1 - IdxNite(Nnite) = i + nnite = nnite + 1 + idxnite(nnite) = i end if end do + !call rrtmgp_inputs_timestep_init(coszrs, get_nstep(), iradsw, iradlw, irad_always, & + ! ncol, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) + !if (errflg /= 0) then + ! call endrun(sub//': '//errmsg) + !end if ! Associate pointers to physics buffer fields itim_old = pbuf_old_tim_idx() @@ -1103,18 +1129,55 @@ subroutine radiation_tend( & stat=istat) call handle_allocate_error(istat, sub, 't_sfc,..,alb_dif') + if (masterproc) then + write(iulog,*) 'peverwhee - set state inputs' + write(iulog,*) nday + write(iulog,*) nlay + write(iulog,*) idxday + write(iulog,*) coszrs + end if + + ! 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) + ! Also calculates modified cloud fraction + !call rrtmgp_inputs_run(dosw, dolw, state%pmid, state%pint, state%t, & + ! nday, idxday, cldfprime, 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, cam_in%lwup, stebol, & + ! ncol, ktopcam, ktoprad, nswbands, cam_in%asdir, cam_in%asdif, & + ! sw_low_bounds, sw_high_bounds, cam_in%aldir, cam_in%aldif, nlay, & + ! pverp, pver, cld, cldfsnow, cldfgrau, graupel_in_rad, & + ! gasnamelength, gaslist, gas_concs_lw, aer_lw, atm_optics_lw, & + ! kdist_lw, sources_lw, aer_sw, atm_optics_sw, gas_concs_sw, & + ! errmsg, errflg) + + ! Prepares state variables, daylit columns, albedos for RRTMGP + ! rrtmgp_pre + 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) + + write(iulog,*) 'peverwhee - after set state' + write(iulog,*) t_sfc(1) + write(iulog,*) emis_sfc(1,1) + write(iulog,*) t_rad(1,1) + write(iulog,*) pmid_rad(1,1) + write(iulog,*) pint_rad(1,1) + write(iulog,*) t_day(1,1) + write(iulog,*) pmid_day(1,1) + write(iulog,*) pint_day(1,1) + write(iulog,*) coszrs_day(1) + write(iulog,*) alb_dir(1,1) + write(iulog,*) alb_dir(1,1) ! 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 + ! rrtmgp_pre call modified_cloud_fraction(ncol, cld, cldfsnow, cldfgrau, cldfprime) !========================! @@ -1125,7 +1188,7 @@ subroutine radiation_tend( & ! Set cloud optical properties in cloud_sw object. call rrtmgp_set_cloud_sw( & - state, pbuf, nlay, nday, idxday, & + state, pbuf, nlay, nday, idxday, ktoprad, ktopcam, & 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, & @@ -1164,7 +1227,7 @@ subroutine radiation_tend( & ! 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) + idxday, ktoprad, ktopcam, gas_concs_sw) ! Compute the gas optics (stored in atm_optics_sw). ! toa_flux is the reference solar source from RRTMGP data. @@ -1183,7 +1246,7 @@ subroutine radiation_tend( & ! 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) + icall, state, pbuf, nday, idxday, nnite, idxnite, aer_sw, ktoprad, ktopcam) if (nday > 0) then @@ -1237,7 +1300,7 @@ subroutine radiation_tend( & ! Set cloud optical properties in cloud_lw object. call rrtmgp_set_cloud_lw( & - state, pbuf, ncol, nlay, nlaycam, & + state, pbuf, ncol, nlay, nlaycam, ktoprad, ktopcam, & cld, cldfsnow, cldfgrau, cldfprime, graupel_in_rad, & kdist_lw, cloud_lw, cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, grau_lw_abs_cloudsim) @@ -1259,7 +1322,7 @@ 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 rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs_lw, ktoprad, ktopcam) ! Compute the gas optics and Planck sources. errmsg = kdist_lw%gas_optics( & @@ -1268,7 +1331,7 @@ subroutine radiation_tend( & 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) + call rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw, ktoprad, ktopcam) ! Increment the gas optics by the aerosol optics. errmsg = aer_lw%increment(atm_optics_lw) diff --git a/src/physics/rrtmgp/radiation_utils.F90 b/src/physics/rrtmgp/radiation_utils.F90 new file mode 100644 index 0000000000..69774d9895 --- /dev/null +++ b/src/physics/rrtmgp/radiation_utils.F90 @@ -0,0 +1,156 @@ +module radiation_utils + use ccpp_kinds, only: kind_phys + + public :: radiation_utils_init + public :: get_sw_spectral_boundaries_ccpp + public :: get_lw_spectral_boundaries_ccpp + + real(kind_phys), allocatable :: wavenumber_low_shortwave(:) + real(kind_phys), allocatable :: wavenumber_high_shortwave(:) + real(kind_phys), allocatable :: wavenumber_low_longwave(:) + real(kind_phys), allocatable :: wavenumber_high_longwave(:) + integer :: nswbands + integer :: nlwbands + logical :: wavenumber_boundaries_set = .false. + +contains + + subroutine radiation_utils_init(nswbands_in, nlwbands_in, low_shortwave, high_shortwave, & + low_longwave, high_longwave, errmsg, errflg) + integer, intent(in) :: nswbands_in + integer, intent(in) :: nlwbands_in + real(kind_phys), intent(in) :: low_shortwave(:) + real(kind_phys), intent(in) :: high_shortwave(:) + real(kind_phys), intent(in) :: low_longwave(:) + real(kind_phys), intent(in) :: high_longwave(:) + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + character(len=256) :: alloc_errmsg + + errflg = 0 + errmsg = '' + nswbands = nswbands_in + nlwbands = nlwbands_in + allocate(wavenumber_low_shortwave(nswbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg,'(a,a)') 'radiation_utils_init: failed to allocate wavenumber_low_shortwave, message: ', & + alloc_errmsg + end if + allocate(wavenumber_high_shortwave(nswbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg,'(a,a)') 'radiation_utils_init: failed to allocate wavenumber_high_shortwave, message: ', & + alloc_errmsg + end if + allocate(wavenumber_low_longwave(nlwbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg,'(a,a)') 'radiation_utils_init: failed to allocate wavenumber_low_longwave, message: ', & + alloc_errmsg + end if + allocate(wavenumber_high_longwave(nlwbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg,'(a,a)') 'radiation_utils_init: failed to allocate wavenumber_high_longwave, message: ', & + alloc_errmsg + end if + + wavenumber_low_shortwave = low_shortwave + wavenumber_high_shortwave = high_shortwave + wavenumber_low_longwave = low_longwave + wavenumber_high_longwave = high_longwave + + wavenumber_boundaries_set = .true. + + end subroutine radiation_utils_init + +!========================================================================================= + + subroutine get_sw_spectral_boundaries_ccpp(low_boundaries, high_boundaries, units, errmsg, errflg) + + ! provide spectral boundaries of each shortwave band + + real(kind_phys), dimension(:), intent(out) :: low_boundaries + real(kind_phys), dimension(:), intent(out) :: high_boundaries + character(*), intent(in) :: units ! requested units + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + character(len=*), parameter :: sub = 'get_sw_spectral_boundaries_ccpp' + !---------------------------------------------------------------------------- + + ! Set error variables + errmsg = '' + errflg = 0 + + if (.not. wavenumber_boundaries_set) then + write(errmsg,'(a,a)') sub, ': ERROR, wavenumber boundaries not set.' + end if + + 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_kind_phys/wavenumber_high_shortwave + high_boundaries = 1.e-2_kind_phys/wavenumber_low_shortwave + case('nm','nanometer','nanometers') + low_boundaries = 1.e7_kind_phys/wavenumber_high_shortwave + high_boundaries = 1.e7_kind_phys/wavenumber_low_shortwave + case('um','micrometer','micrometers','micron','microns') + low_boundaries = 1.e4_kind_phys/wavenumber_high_shortwave + high_boundaries = 1.e4_kind_phys/wavenumber_low_shortwave + case('cm','centimeter','centimeters') + low_boundaries = 1._kind_phys/wavenumber_high_shortwave + high_boundaries = 1._kind_phys/wavenumber_low_shortwave + case default + write(errmsg, '(a,a,a)') sub, ': ERROR, requested spectral units not recognized: ', units + errflg = 1 + end select + + end subroutine get_sw_spectral_boundaries_ccpp + +!========================================================================================= + +subroutine get_lw_spectral_boundaries_ccpp(low_boundaries, high_boundaries, units, errmsg, errflg) + + ! provide spectral boundaries of each longwave band + + real(kind_phys), intent(out) :: low_boundaries(nlwbands), high_boundaries(nlwbands) + character(*), intent(in) :: units ! requested units + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + character(len=*), parameter :: sub = 'get_lw_spectral_boundaries_ccpp' + !---------------------------------------------------------------------------- + + ! Set error variables + errmsg = '' + errflg = 0 + + if (.not. wavenumber_boundaries_set) then + write(errmsg,'(a,a)') sub, ': ERROR, wavenumber boundaries not set.' + end if + + 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_kind_phys/wavenumber_high_longwave + high_boundaries = 1.e-2_kind_phys/wavenumber_low_longwave + case('nm','nanometer','nanometers') + low_boundaries = 1.e7_kind_phys/wavenumber_high_longwave + high_boundaries = 1.e7_kind_phys/wavenumber_low_longwave + case('um','micrometer','micrometers','micron','microns') + low_boundaries = 1.e4_kind_phys/wavenumber_high_longwave + high_boundaries = 1.e4_kind_phys/wavenumber_low_longwave + case('cm','centimeter','centimeters') + low_boundaries = 1._kind_phys/wavenumber_high_longwave + high_boundaries = 1._kind_phys/wavenumber_low_longwave + case default + write(errmsg, '(a,a,a)') sub, ': ERROR, requested spectral units not recognized: ', units + errflg = 1 + end select + +end subroutine get_lw_spectral_boundaries_ccpp + + +end module radiation_utils diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 4f73ae9029..5cc2f55896 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -1,1012 +1,732 @@ module rrtmgp_inputs - -!-------------------------------------------------------------------------------- -! 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 -! CAM and RRTMGP arrays. -!-------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8=>shr_kind_r8 -use ppgrid, only: pcols, pver, pverp - -use physconst, only: stebol, pi - -use physics_types, only: physics_state -use physics_buffer, only: physics_buffer_desc -use camsrfexch, only: cam_in_t - -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 - -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 -use error_messages, only: alloc_err - -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 - - -! 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 - ! 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) - -! 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 -!================================================================================================== - -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) :: ktcam - integer, intent(in) :: 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 - -!========================================================================================= - -subroutine 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) - - ! 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 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 - real(r8), intent(in) :: coszrs(:) ! cosine of solar zenith angle - class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! spectral information - - 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 - - ! local variables - integer :: i, k, iband - - real(r8) :: tref_min, tref_max - - character(len=*), parameter :: sub='rrtmgp_set_state' - character(len=512) :: errmsg - !-------------------------------------------------------------------------------- - - 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 - - ! 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:) - - ! Add extra layer values if needed. - if (nlay == pverp) then - t_rad(:,1) = state%t(: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 - - ! next interface down in LT will always be > 1Pa - ! but in MT we apply adjustment to have it be 1.02 Pa if it was too high - where (pint_rad(:,2) <= pint_rad(:,1)) pint_rad(:,2) = pint_rad(:,1)+0.01_r8 - - ! set the highest pmid (in the "extra layer") to the midpoint (guarantees > 1Pa) - pmid_rad(:,1) = pint_rad(:,1) + 0.5_r8 * (pint_rad(:,2) - pint_rad(:,1)) - - ! For case of CAM MT, also ensure pint_rad(:,2) > pint_rad(:,1) & pmid_rad(:,2) > max(pmid_rad(:,1), min_pressure) - where (pmid_rad(:,2) <= kdist_sw%get_press_min()) pmid_rad(:,2) = pint_rad(:,2) + 0.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 - - ! Limit temperatures to be within the limits of RRTMGP validity. - tref_min = kdist_sw%get_temp_min() - tref_max = kdist_sw%get_temp_max() - 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 - 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 - - ! 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 based on a dividing line of - ! 0.7 micron, or 14286 cm^-1 - do iband = 1,nswbands - 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 - 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(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)) - 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_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 - - ! 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 - -!========================================================================================= - -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 - ! This function doesn't distinquish between visible and UV. - - ! wavenumber in inverse cm (cm^-1) - real(r8), intent(in) :: wavenumber - - ! 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 - is_visible = .true. - else - is_visible = .false. - end if - -end function is_visible + use machine, only: kind_phys + 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_gas_concentrations, only: ty_gas_concs + use mo_source_functions, only: ty_source_func_lw + use string_utils, only: to_lower + use radiation_utils, only: radiation_utils_init, get_sw_spectral_boundaries_ccpp + + implicit none + private + + public :: rrtmgp_inputs_register + public :: rrtmgp_inputs_timestep_init + public :: rrtmgp_inputs_init + public :: rrtmgp_inputs_run + + contains +!> \section arg_table_rrtmgp_inputs_register Argument Table +!! \htmlinclude rrtmgp_inputs_register.html +!! + subroutine rrtmgp_inputs_register(gaslist, nradgas, gasnamelength, errmsg, errflg) +! use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + ! Inputs + character(len=*), intent(in) :: gaslist(:) + integer, intent(in) :: nradgas + integer, intent(in) :: gasnamelength + ! Outputs + ! type(ccpp_constituent_properties_t), allocatable, intent(out) :: const_props(:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: gas_index + real(kind_phys) :: minmmr + + ! Set error variables + errflg = 0 + errmsg = '' + ! Set minimum mass mixing ratio supported by radiation implementation + minmmr = epsilon(1._kind_phys) + ! Register all gases in gaslist + ! peverwhee - compare vs rad_constituents! + ! do gas_index = 1, ndradgas + ! call const_props(gas_index)%instantiate( & + ! std_name = gaslist(gas_index), & + ! long_name = gaslist(gas_index), & + ! units = 'kg-1', & + ! vertical_dim = 'vertical_layer_dimension', & + ! min_value = minmmr, & + ! advected = .false., & + ! water_species = .false., & + ! mixing_ratio_type = 'dry', & + ! errcode = errflg, & + ! errmsg = errmsg) + ! if (errflg /= 0) then + ! return + ! end if + ! end do + + + end subroutine rrtmgp_inputs_register +!> \section arg_table_rrtmgp_inputs_init Argument Table +!! \htmlinclude rrtmgp_inputs_init.html +!! + subroutine rrtmgp_inputs_init(ktopcam, ktoprad, nlaycam, sw_low_bounds, sw_high_bounds, nswbands, & + pref_edge, nlay, pver, pverp, kdist_sw, kdist_lw, qrl, is_first_step, use_rad_dt_cosz, & + timestep_size, nstep, iradsw, dt_avg, irad_always, is_first_restart_step, & + nlwbands, nradgas, gasnamelength, iulog, idx_sw_diag, idx_nir_diag, idx_uv_diag, & + idx_sw_cloudsim, idx_lw_diag, idx_lw_cloudsim, gaslist, nswgpts, nlwgpts, nlayp, & + nextsw_cday, current_cal_day, errmsg, errflg) + + ! Inputs + integer, intent(in) :: nswbands + integer, intent(in) :: pverp + integer, intent(in) :: pver + integer, intent(in) :: iradsw + integer, intent(in) :: timestep_size + integer, intent(in) :: nstep + integer, intent(in) :: nlwbands + integer, intent(in) :: nradgas + integer, intent(in) :: iulog + integer, intent(in) :: gasnamelength + real(kind_phys), intent(in) :: current_cal_day + real(kind_phys), dimension(:), intent(in) :: pref_edge + type(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw + type(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw + logical, intent(in) :: is_first_step + logical, intent(in) :: is_first_restart_step + logical, intent(in) :: use_rad_dt_cosz + character(len=*), dimension(:), intent(in) :: gaslist + + ! Outputs + integer, intent(out) :: ktopcam + integer, intent(out) :: ktoprad + integer, intent(out) :: nlaycam + integer, intent(out) :: nlay + integer, intent(out) :: nlayp + integer, intent(out) :: idx_sw_diag + integer, intent(out) :: idx_nir_diag + integer, intent(out) :: idx_uv_diag + integer, intent(out) :: idx_sw_cloudsim + integer, intent(out) :: idx_lw_diag + integer, intent(out) :: idx_lw_cloudsim + integer, intent(out) :: nswgpts + integer, intent(out) :: nlwgpts + real(kind_phys), intent(out) :: nextsw_cday + real(kind_phys), dimension(:), intent(out) :: sw_low_bounds + real(kind_phys), dimension(:), intent(out) :: sw_high_bounds + real(kind_phys), dimension(:,:), intent(out) :: qrl + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: irad_always + real(kind_phys), intent(inout) :: dt_avg ! averaging time interval for zenith angle + + ! Local variables + real(kind_phys), target :: wavenumber_low_shortwave(nswbands) + real(kind_phys), target :: wavenumber_high_shortwave(nswbands) + real(kind_phys), target :: wavenumber_low_longwave(nlwbands) + real(kind_phys), target :: wavenumber_high_longwave(nlwbands) + character(len=gasnamelength) :: gaslist_lc(nradgas) + + ! Set error variables + errflg = 0 + errmsg = '' + + ! Read RRTMGP coefficients files and initialize kdist objects. + ! peverwhee - Will be inputs to rrtmgp_gas_optics_init +! call coefs_init(coefs_sw_file, available_gases, kdist_sw) +! call coefs_init(coefs_lw_file, available_gases, kdist_lw) + + + ! 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._kind_phys ) ! pascals (0.01 mbar) + nlayp = 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 + nlaycam = pver + else if (nlay == (pverp-1)) then + ! Special case nlay == (pverp-1) -- topmost interface outside bounds (CAM MT config), treat as if it is ok. + ktopcam = 1 + ktoprad = 2 + nlaycam = pver + nlay = nlay+1 ! reassign the value so later code understands to treat this case like nlay==pverp + write(iulog,*) 'RADIATION_INIT: Special case of 1 model interface at p < 1Pa. Top layer will be INCLUDED in radiation calculation.' + write(iulog,*) 'RADIATION_INIT: nlay = ',nlay, ' same as pverp: ',nlay==pverp + else + ! nlay < pverp. nlay layers are used in radiation calcs, and they are + ! all CAM layers. + ktopcam = pver - nlay + 1 + ktoprad = 1 + nlaycam = nlay + end if + + ! 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, nswbands, nlwbands, idx_sw_diag, idx_nir_diag, & + idx_uv_diag, idx_sw_cloudsim, idx_lw_diag, idx_lw_cloudsim, nswgpts, nlwgpts, & + wavenumber_low_shortwave, wavenumber_high_shortwave, wavenumber_low_longwave, & + wavenumber_high_longwave, errmsg, errflg) + if (errflg /= 0) then + return + end if + + call radiation_utils_init(nswbands, nlwbands, wavenumber_low_shortwave, wavenumber_high_shortwave, & + wavenumber_low_longwave, wavenumber_high_longwave, errmsg, errflg) + if (errflg /= 0) then + return + end if + + ! Initialize the SW band boundaries + call get_sw_spectral_boundaries_ccpp(sw_low_bounds, sw_high_bounds, 'cm^-1', errmsg, errflg) + if (errflg /= 0) then + return + end if + + if (is_first_step) then + qrl = 0._kind_phys + end if + + ! Set the radiation timestep for cosz calculations if requested using + ! the adjusted iradsw value from radiation + if (use_rad_dt_cosz) then + dt_avg = iradsw*timestep_size + end if + + ! "irad_always" is number of time steps to execute radiation continuously from + ! start of initial OR restart run + if (irad_always > 0) then + irad_always = irad_always + nstep + end if + + ! Surface components to get radiation computed today + if (.not. is_first_restart_step) then + nextsw_cday = current_cal_day + end if + + end subroutine rrtmgp_inputs_init + +!> \section arg_table_rrtmgp_inputs_timestep_init Argument Table +!! \htmlinclude rrtmgp_inputs_timestep_init.html +!! + subroutine rrtmgp_inputs_timestep_init(coszrs, nstep, iradsw, iradlw, irad_always, & + ncol, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + real(kind_phys), dimension(:), intent(in) :: coszrs + integer, intent(in) :: nstep + integer, intent(in) :: iradsw + integer, intent(in) :: iradlw + integer, intent(in) :: irad_always + integer, intent(in) :: ncol + integer, intent(out) :: nday + integer, intent(out) :: nnite + integer, dimension(:), intent(out) :: idxday + integer, dimension(:), intent(out) :: idxnite + logical, intent(out) :: dosw + logical, intent(out) :: dolw + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: idx + + ! Set error variables + errflg = 0 + errmsg = '' + + ! Gather night/day column indices. + nday = 0 + nnite = 0 + do idx = 1, ncol + if ( coszrs(idx) > 0.0_kind_phys ) then + nday = nday + 1 + idxday(nday) = idx + else + nnite = nnite + 1 + idxnite(nnite) = idx + end if + end do + + ! Determine if we're going to do longwave and/or shortwave this timestep + dosw = nstep == 0 .or. iradsw == 1 & + .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + dolw = nstep == 0 .or. iradlw == 1 & + .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + end subroutine rrtmgp_inputs_timestep_init + +!> \section arg_table_rrtmgp_inputs_run Argument Table +!! \htmlinclude rrtmgp_inputs_run.html +!! + subroutine rrtmgp_inputs_run(dosw, dolw, pmid, pint, t, nday, idxday, cldfprime, & + 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, lwup, stebol, ncol, ktopcam, ktoprad, & + nswbands, asdir, asdif, sw_low_bounds, sw_high_bounds, & + aldir, aldif, nlay, pverp, pver, cld, cldfsnow, & + cldfgrau, graupel_in_rad, gasnamelength, gaslist, & + gas_concs_lw, aer_lw, atm_optics_lw, kdist_lw, & + sources_lw, aer_sw, atm_optics_sw, gas_concs_sw, & + errmsg, errflg) + ! Inputs + logical, intent(in) :: graupel_in_rad + integer, intent(in) :: ncol + integer, intent(in) :: pver + integer, intent(in) :: pverp + integer, intent(in) :: nlay + integer, intent(in) :: nswbands + integer, intent(in) :: ktopcam + integer, intent(in) :: ktoprad + integer, intent(in) :: gasnamelength + integer, intent(in) :: nday + logical, intent(in) :: dosw + logical, intent(in) :: dolw + integer, dimension(:), intent(in) :: idxday + real(kind_phys), dimension(:,:), intent(in) :: pmid + real(kind_phys), dimension(:,:), intent(in) :: pint + real(kind_phys), dimension(:,:), intent(in) :: t + real(kind_phys), dimension(:,:), intent(in) :: cldfsnow + real(kind_phys), dimension(:,:), intent(in) :: cldfgrau + real(kind_phys), dimension(:,:), intent(in) :: cld + real(kind_phys), dimension(:), intent(in) :: sw_low_bounds + real(kind_phys), dimension(:), intent(in) :: sw_high_bounds + real(kind_phys), dimension(:), intent(in) :: coszrs + real(kind_phys), dimension(:), intent(in) :: lwup + real(kind_phys), dimension(:), intent(in) :: asdir + real(kind_phys), dimension(:), intent(in) :: asdif + real(kind_phys), dimension(:), intent(in) :: aldir + real(kind_phys), dimension(:), intent(in) :: aldif + real(kind_phys), intent(in) :: stebol ! stefan-boltzmann constant + class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! spectral information + class(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw ! spectral information + character(len=*), dimension(:), intent(in) :: gaslist + ! Outputs + real(kind_phys), dimension(:,:), intent(out) :: t_rad + real(kind_phys), dimension(:,:), intent(out) :: pmid_rad + real(kind_phys), dimension(:,:), intent(out) :: pint_rad + real(kind_phys), dimension(:,:), intent(out) :: t_day + real(kind_phys), dimension(:,:), intent(out) :: pint_day + real(kind_phys), dimension(:,:), intent(out) :: pmid_day + real(kind_phys), dimension(:,:), intent(out) :: emis_sfc + real(kind_phys), dimension(:,:), intent(out) :: alb_dir + real(kind_phys), dimension(:,:), intent(out) :: alb_dif + real(kind_phys), dimension(:,:), intent(out) :: cldfprime ! modiifed cloud fraciton + + real(kind_phys), dimension(:), intent(out) :: t_sfc + real(kind_phys), dimension(:), intent(out) :: coszrs_day + type(ty_gas_concs), intent(out) :: gas_concs_lw + type(ty_optical_props_1scl), intent(out) :: atm_optics_lw + type(ty_optical_props_1scl), intent(out) :: aer_lw + type(ty_source_func_lw), intent(out) :: sources_lw + type(ty_gas_concs), intent(out) :: gas_concs_sw + type(ty_optical_props_2str), intent(out) :: atm_optics_sw + type(ty_optical_props_2str), intent(out) :: aer_sw + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + real(kind_phys) :: tref_min + real(kind_phys) :: tref_max + integer :: idx, kdx, iband + character(len=gasnamelength) :: gaslist_lc(size(gaslist)) + + ! Set error variables + errmsg = '' + errflg = 0 + + if (.not. dosw .and. .not. dolw) then + return + end if + + ! RRTMGP set state + t_sfc = sqrt(sqrt(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._kind_phys + + ! Level ordering is the same for both CAM and RRTMGP (top to bottom) + t_rad(:,ktoprad:) = t(:ncol,ktopcam:) + pmid_rad(:,ktoprad:) = pmid(:ncol,ktopcam:) + pint_rad(:,ktoprad:) = pint(:ncol,ktopcam:) + + ! Add extra layer values if needed. + if (nlay == pverp) then + t_rad(:,1) = t(: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_kind_phys + + ! next interface down in LT will always be > 1Pa + ! but in MT we apply adjustment to have it be 1.02 Pa if it was too high + where (pint_rad(:,2) <= pint_rad(:,1)) pint_rad(:,2) = pint_rad(:,1)+0.01_kind_phys + + ! set the highest pmid (in the "extra layer") to the midpoint (guarantees > 1Pa) + pmid_rad(:,1) = pint_rad(:,1) + 0.5_kind_phys * (pint_rad(:,2) - pint_rad(:,1)) + + ! For case of CAM MT, also ensure pint_rad(:,2) > pint_rad(:,1) & pmid_rad(:,2) > max(pmid_rad(:,1), min_pressure) + where (pmid_rad(:,2) <= kdist_sw%get_press_min()) pmid_rad(:,2) = pint_rad(:,2) + 0.01_kind_phys + 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_kind_phys + pmid_rad(:,1) = 0.5_kind_phys * (pint_rad(:,1) + pint_rad(:,2)) + end if + + ! Limit temperatures to be within the limits of RRTMGP validity. + tref_min = kdist_sw%get_temp_min() + tref_max = kdist_sw%get_temp_max() + t_rad = merge(t_rad, tref_min, t_rad > tref_min) + t_rad = merge(t_rad, tref_max, t_rad < tref_max) + t_sfc = merge(t_sfc, tref_min, t_sfc > tref_min) + t_sfc = merge(t_sfc, tref_max, t_sfc < tref_max) + + ! Construct arrays containing only daylight columns + do idx = 1, nday + t_day(idx,:) = t_rad(idxday(idx),:) + pmid_day(idx,:) = pmid_rad(idxday(idx),:) + pint_day(idx,:) = pint_rad(idxday(idx),:) + coszrs_day(idx) = coszrs(idxday(idx)) + end do + + ! 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 based on a dividing line of + ! 0.7 micron, or 14286 cm^-1 + do iband = 1,nswbands + if (is_visible(sw_low_bounds(iband)) .and. & + is_visible(sw_high_bounds(iband))) then + + ! Entire band is in the visible + do idx = 1, nday + alb_dir(iband,idx) = asdir(idxday(idx)) + alb_dif(iband,idx) = asdif(idxday(idx)) + end do + + 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 idx = 1, nday + alb_dir(iband,idx) = aldir(idxday(idx)) + alb_dif(iband,idx) = aldif(idxday(idx)) + 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 idx = 1, nday + alb_dir(iband,idx) = 0.5_kind_phys * (aldir(idxday(idx)) + asdir(idxday(idx))) + alb_dif(iband,idx) = 0.5_kind_phys * (aldif(idxday(idx)) + asdif(idxday(idx))) + end do + end if + end do + + ! modified cloud fraction + ! Compute modified cloud fraction, cldfprime. + ! 1. initialize as cld + ! 2. modify for snow. use max(cld, cldfsnow) + ! 3. modify for graupel if graupel_in_rad is true. + ! use max(cldfprime, cldfgrau) + do kdx = 1, pver + do idx = 1, ncol + cldfprime(idx,kdx) = max(cld(idx,kdx), cldfsnow(idx,kdx)) + end do + end do + + if (graupel_in_rad) then + do kdx = 1, pver + do idx = 1, ncol + cldfprime(idx,kdx) = max(cldfprime(idx,kdx), cldfgrau(idx,kdx)) + end do + end do + end if + + ! 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 idx = 1, size(gaslist) + gaslist_lc(idx) = to_lower(gaslist(idx)) + end do + + ! If no daylight columns, can't create empty RRTMGP objects + if (dosw .and. nday > 0) then + ! Initialize object for gas concentrations. + errmsg = gas_concs_sw%init(gaslist_lc) + if (len_trim(errmsg) > 0) then + errflg = 1 + return + end if + + ! 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 + errflg = 1 + return + end if + + ! 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 + errflg = 1 + return + end if + end if + + if (dolw) then + ! Initialize object for gas concentrations + errmsg = gas_concs_lw%init(gaslist_lc) + if (len_trim(errmsg) > 0) then + errflg = 1 + return + end if + + ! Initialize object for combined gas + aerosol + cloud optics. + errmsg = atm_optics_lw%alloc_1scl(ncol, nlay, kdist_lw) + if (len_trim(errmsg) > 0) then + errflg = 1 + return + end if + + ! 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 + errflg = 1 + return + end if + + ! Initialize object for Planck sources. + errmsg = sources_lw%alloc(ncol, nlay, kdist_lw) + if (len_trim(errmsg) > 0) then + errflg = 1 + return + end if + end if + + + end subroutine rrtmgp_inputs_run !========================================================================================= - -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 = amdw - case ('CO2') - massratio = amdc - case ('O3') - massratio = amdo - case ('CH4') - massratio = amdm - case ('N2O') - massratio = amdn - case ('O2') - massratio = amdo2 - case ('CFC11') - massratio = amdc1 - case ('CFC12') - massratio = amdc2 - case default - call endrun(sub//": Invalid gas: "//trim(gas_name)) - end select - -end function get_molar_mass_ratio - +! HELPER FUNCTIONS ! !========================================================================================= + subroutine set_wavenumber_bands(kdist_sw, kdist_lw, nswbands, nlwbands, idx_sw_diag, idx_nir_diag, & + idx_uv_diag, idx_sw_cloudsim, idx_lw_diag, idx_lw_cloudsim, nswgpts, nlwgpts, & + wavenumber_low_shortwave, wavenumber_high_shortwave, wavenumber_low_longwave, & + wavenumber_high_longwave, errmsg, errflg) + ! Set the low and high limits of the wavenumber grid for sw and lw. + ! Values come from RRTMGP coefficients datasets, and are stored in the + ! kdist objects. + ! + ! Set band indices for bands containing specific wavelengths. -subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, gas_concs, idxday) - - ! 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 - 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 - - 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 + ! Arguments + type(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw + type(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw + integer, intent(in) :: nswbands + integer, intent(in) :: nlwbands + + integer, intent(out) :: idx_sw_diag + integer, intent(out) :: idx_nir_diag + integer, intent(out) :: idx_uv_diag + integer, intent(out) :: idx_sw_cloudsim + integer, intent(out) :: idx_lw_diag + integer, intent(out) :: idx_lw_cloudsim + integer, intent(out) :: nswgpts + integer, intent(out) :: nlwgpts + real(kind_phys), dimension(:), intent(out) :: wavenumber_low_shortwave + real(kind_phys), dimension(:), intent(out) :: wavenumber_high_shortwave + real(kind_phys), dimension(:), intent(out) :: wavenumber_low_longwave + real(kind_phys), dimension(:), intent(out) :: wavenumber_high_longwave + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! Local variables - integer :: i, idx(numactivecols) integer :: istat - real(r8), pointer :: gas_mmr(:,:) - real(r8), allocatable :: gas_vmr(:,:) - real(r8), allocatable :: mmr(:,:) - real(r8) :: massratio - - ! For ozone profile above model - real(r8) :: P_top, P_int, P_mid, alpha, beta, a, b, chi_mid, chi_0, chi_eff + real(kind_phys), allocatable :: values(:,:) - character(len=128) :: errmsg - character(len=*), parameter :: sub = 'rad_gas_get_vmr' + character(len=*), parameter :: sub = 'set_wavenumber_bands' !---------------------------------------------------------------------------- - ! 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), 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:) - 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 - - ! 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. - massratio = get_molar_mass_ratio(gas_name) - gas_vmr = mmr * massratio - - ! 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 - P_top = 50.0_r8 - do i = 1, numactivecols - 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 = log(P_int/P_top) - beta = log(P_mid/P_int)/log(P_mid/P_top) - - a = ( (1._r8 + alpha) * exp(-alpha) - 1._r8 ) / alpha - b = 1._r8 - exp(-alpha) - - 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 - end if - end do + ! Initialize error variables + errflg = 0 + errmsg = '' + ! Check that number of sw/lw bands in gas optics files matches the parameters. + if (kdist_sw%get_nband() /= nswbands) then + write(errmsg,'(a, a,i4,a,i4)') sub, ': ERROR: number of sw bands in file, ', kdist_sw%get_nband(), & + ", doesn't match parameter nswbands= ", nswbands + errflg = 1 + return end if - - 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)) + if (kdist_lw%get_nband() /= nlwbands) then + write(errmsg,'(a, a,i4,a,i4)') sub, ': ERROR: number of lw bands in file, ', kdist_lw%get_nband(), & + ", doesn't match parameter nlwbands= ", nlwbands + errflg = 1 + return end if - deallocate(gas_vmr) - deallocate(mmr) - -end subroutine rad_gas_get_vmr - -!================================================================================================== + nswgpts = kdist_sw%get_ngpt() + nlwgpts = kdist_lw%get_ngpt() -subroutine rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs) - - ! 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 - ! 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) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - integer, intent(in) :: nlay - type(ty_gas_concs), intent(inout) :: gas_concs - - ! local variables - integer :: i, ncol - character(len=*), parameter :: sub = 'rrtmgp_set_gases_lw' - !-------------------------------------------------------------------------------- - - ncol = state%ncol - 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 - -!================================================================================================== - -subroutine rrtmgp_set_gases_sw( & - icall, state, pbuf, nlay, nday, & - idxday, gas_concs) - - ! Return gas_concs with gas volume mixing ratio on DAYLIT columns. - ! Set all gases in radconstants gaslist. - - ! arguments - integer, intent(in) :: icall ! index of climate/diagnostic radiation call - type(physics_state), target, intent(in) :: state - 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 - integer :: i - character(len=*), parameter :: sub = 'rrtmgp_set_gases_sw' - !---------------------------------------------------------------------------- - - ! 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, idxday=idxday) - end do - -end subroutine rrtmgp_set_gases_sw - -!================================================================================================== - -subroutine rrtmgp_set_cloud_lw( & - 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. - ! Initialize optical properties object (cloud_lw) and load with MCICA columns. - - ! 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" - 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 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) - - ! Local variables - - 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) - 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) :: 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' - !-------------------------------------------------------------------------------- - - ! 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,:) + ! SW band bounds in cm^-1 + allocate( values(2,nswbands), stat=istat ) + if (istat/=0) then + write(errmsg, '(a,a)') sub, ': ERROR allocating array: values(2,nswbands)' + errflg = 1 + return 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 + values = kdist_sw%get_band_lims_wavenumber() + wavenumber_low_shortwave = values(1,:) + wavenumber_high_shortwave = values(2,:) + + ! Indices into specific bands + call get_band_index_by_value('sw', 500.0_kind_phys, 'nm', nswbands, & + wavenumber_low_shortwave, wavenumber_high_shortwave, idx_sw_diag, errmsg, errflg) + if (errflg /= 0) then + return 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,:,:) - - ! Extract just the layers of CAM where RRTMGP does calculations. - - ! 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:) - - ! 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 ) - - 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)) + call get_band_index_by_value('sw', 1000.0_kind_phys, 'nm', nswbands, & + wavenumber_low_shortwave, wavenumber_high_shortwave, idx_nir_diag, errmsg, errflg) + if (errflg /= 0) then + return 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 - - ! Set the properties on g-points. - do i = 1, nlwgpts - cloud_lw%tau(:,ktoprad:,i) = taucmcl(i,:,:) - 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)) + call get_band_index_by_value('sw', 400._kind_phys, 'nm', nswbands, & + wavenumber_low_shortwave, wavenumber_high_shortwave, idx_uv_diag, errmsg, errflg) + if (errflg /= 0) then + return end if - -end subroutine rrtmgp_set_cloud_lw - -!================================================================================================== - -subroutine rrtmgp_set_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. - - ! arguments - 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) :: 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. - - 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 ! 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 :: 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 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 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 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 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 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 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. - - ! Arrays for converting from CAM chunks to RRTMGP inputs. - 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(:,:,:) - 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' - !-------------------------------------------------------------------------------- - - 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._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) & - + 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,:) + call get_band_index_by_value('sw', 0.67_kind_phys, 'micron', nswbands, & + wavenumber_low_shortwave, wavenumber_high_shortwave, idx_sw_cloudsim, errmsg, errflg) + if (errflg /= 0) then + return 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 + deallocate(values) - ! 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,:) + ! LW band bounds in cm^-1 + allocate( values(2,nlwbands), stat=istat ) + if (istat/=0) then + write(errmsg, '(a,a)') sub, ': ERROR allocating array: values(2,nlwbands)' + errflg = 1 + return end if - if (associated(cldfgrau) .and. graupel_in_rad) then - grau_tau(:,:ncol,:) = grau_tau(rrtmg_to_rrtmgp_swbands,:ncol,:) + values = kdist_lw%get_band_lims_wavenumber() + wavenumber_low_longwave = values(1,:) + wavenumber_high_longwave = values(2,:) + + ! Indices into specific bands + call get_band_index_by_value('lw', 1000.0_kind_phys, 'cm^-1', nlwbands, & + wavenumber_low_longwave, wavenumber_high_longwave, idx_lw_diag, errmsg, errflg) + if (errflg /= 0) then + return 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,:,:) - - ! 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), 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. - 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 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, & - 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. - 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,:,:) - 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]. - 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 - - ! 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 ) - + call get_band_index_by_value('lw', 10.5_kind_phys, 'micron', nlwbands, & + wavenumber_low_longwave, wavenumber_high_longwave, idx_lw_cloudsim, errmsg, errflg) + if (errflg /= 0) then + return end if -end subroutine rrtmgp_set_cloud_sw + end subroutine set_wavenumber_bands -!================================================================================================== - -subroutine rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw) +!========================================================================================= - ! Load LW aerosol optical properties into the RRTMGP object. + subroutine get_band_index_by_value(swlw, targetvalue, units, nbnds, wavenumber_low, & + wavenumber_high, ans, errmsg, errflg) - ! Arguments - integer, intent(in) :: icall - type(physics_state), target, intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) + ! Find band index for requested wavelength/wavenumber. - type(ty_optical_props_1scl), intent(inout) :: aer_lw - - ! Local variables - integer :: ncol + character(len=*), intent(in) :: swlw ! sw or lw bands + real(kind_phys), intent(in) :: targetvalue + character(len=*), intent(in) :: units ! units of targetvalue + integer, intent(in) :: nbnds + real(kind_phys), target, dimension(:), intent(in) :: wavenumber_low + real(kind_phys), target, dimension(:), intent(in) :: wavenumber_high + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(out) :: ans - ! Aerosol LW absorption optical depth - real(r8) :: aer_lw_abs (pcols,pver,nlwbands) + ! local + real(kind_phys), pointer, dimension(:) :: lowboundaries, highboundaries + real(kind_phys) :: tgt + integer :: idx - character(len=*), parameter :: sub = 'rrtmgp_set_aer_lw' - character(len=128) :: errmsg - !-------------------------------------------------------------------------------- - - ncol = state%ncol + character(len=*), parameter :: sub = 'get_band_index_by_value' + !---------------------------------------------------------------------------- - ! Get aerosol longwave optical properties. - call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) + ! Initialize error variables + errflg = 0 + errmsg = '' + lowboundaries => wavenumber_low + highboundaries => wavenumber_high + if (trim(swlw) /= 'sw' .and. trim(swlw) /= 'lw') then + write(errmsg,'(a,a)') 'rrtmgp_inputs: get_band_index_by_value: type of bands not recognized: ', swlw + errflg = 1 + return + end if - ! If there is an extra layer in the radiation then this initialization - ! will provide zero optical depths there. - aer_lw%tau = 0.0_r8 + ! 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_kind_phys / (targetvalue * 1.e2_kind_phys) + case('nm','nanometer','nanometers') + tgt = 1.0_kind_phys / (targetvalue * 1.e-7_kind_phys) + case('um','micrometer','micrometers','micron','microns') + tgt = 1.0_kind_phys / (targetvalue * 1.e-4_kind_phys) + case('cm','centimeter','centimeters') + tgt = 1._kind_phys/targetvalue + case default + write(errmsg,'(a,a)') 'rrtmgp_inputs: get_band_index_by_value: units not recognized: ', units + errflg = 1 + end select - aer_lw%tau(:ncol, ktoprad:, :) = aer_lw_abs(:ncol, ktopcam:, :) + ! now just loop through the array + ans = 0 + do idx = 1,nbnds + if ((tgt > lowboundaries(idx)) .and. (tgt <= highboundaries(idx))) then + ans = idx + exit + end if + end do - errmsg = aer_lw%validate() - if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: aer_lw%validate: '//trim(errmsg)) + if (ans == 0) then + write(errmsg,'(f10.3,a,a)') targetvalue, ' ', trim(units) + errflg = 1 end if -end subroutine rrtmgp_set_aer_lw + + end subroutine get_band_index_by_value -!================================================================================================== + !========================================================================================= -subroutine rrtmgp_set_aer_sw( & - icall, state, pbuf, nday, idxday, nnite, idxnite, aer_sw) + pure logical function is_visible(wavenumber) - ! Load SW aerosol optical properties into the RRTMGP object. + ! 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. - ! Arguments - 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 - - ! 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' - !-------------------------------------------------------------------------------- - - ! 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) - - ! 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) - - 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) + ! wavenumber in inverse cm (cm^-1) + real(kind_phys), intent(in) :: wavenumber - end if + ! Set threshold between visible and infrared to 0.7 micron, or 14286 cm^-1 + real(kind_phys), parameter :: visible_wavenumber_threshold = 14286._kind_phys ! cm^-1 -end subroutine rrtmgp_set_aer_sw + if (wavenumber > visible_wavenumber_threshold) then + is_visible = .true. + else + is_visible = .false. + end if -!================================================================================================== + end function is_visible end module rrtmgp_inputs diff --git a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 new file mode 100644 index 0000000000..270fe68ca1 --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 @@ -0,0 +1,1056 @@ +module rrtmgp_inputs_cam + +!-------------------------------------------------------------------------------- +! 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 +! CAM and RRTMGP arrays. +!-------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use ppgrid, only: pcols, pver, pverp + +use physconst, only: stebol, pi + +use physics_types, only: physics_state +use physics_buffer, only: physics_buffer_desc +use camsrfexch, only: cam_in_t + +use radconstants, only: nradgas, gaslist, nswbands, nlwbands, nswgpts, nlwgpts + +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 +use error_messages, only: alloc_err +use radiation_utils, only: get_sw_spectral_boundaries_ccpp + +implicit none +private +save + +public :: & + rrtmgp_set_state, & + rrtmgp_inputs_cam_init, & + rrtmgp_set_gases_lw, & + rrtmgp_set_gases_sw, & + rrtmgp_set_cloud_lw, & + rrtmgp_set_cloud_sw, & + rrtmgp_set_aer_lw, & + rrtmgp_set_aer_sw + + +! 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 +real(r8) :: sw_low_bounds(nswbands) +real(r8) :: sw_high_bounds(nswbands) +integer :: ktopcam +integer :: ktoprad +integer :: idx_sw_diag +integer :: idx_nir_diag +integer :: idx_uv_diag +integer :: idx_sw_cloudsim +integer :: idx_lw_diag +integer :: idx_lw_cloudsim + +! 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 +!================================================================================================== + +!================================================================================================== +subroutine rrtmgp_inputs_cam_init(ktcam, ktrad, idx_sw_diag_in, idx_nir_diag_in, idx_uv_diag_in, & + idx_sw_cloudsim_in, idx_lw_diag_in, idx_lw_cloudsim_in) + + ! 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) :: ktcam + integer, intent(in) :: ktrad + integer, intent(in) :: idx_sw_diag_in + integer, intent(in) :: idx_nir_diag_in + integer, intent(in) :: idx_uv_diag_in + integer, intent(in) :: idx_sw_cloudsim_in + integer, intent(in) :: idx_lw_diag_in + integer, intent(in) :: idx_lw_cloudsim_in + character(len=512) :: errmsg + integer :: errflg + + ktopcam = ktcam + ktoprad = ktrad + idx_sw_diag = idx_sw_diag_in + idx_nir_diag = idx_nir_diag_in + idx_uv_diag = idx_uv_diag_in + idx_sw_cloudsim = idx_sw_cloudsim_in + idx_lw_diag = idx_lw_diag_in + idx_lw_cloudsim = idx_lw_cloudsim_in + + ! Initialize the module data containing the SW band boundaries. + call get_sw_spectral_boundaries_ccpp(sw_low_bounds, sw_high_bounds, 'cm^-1', errmsg, errflg) + write(iulog,*) 'peverwhee - after cam init' + write(iulog,*) ktopcam + write(iulog,*) ktoprad + write(iulog,*) sw_low_bounds + write(iulog,*) sw_high_bounds + write(iulog,*) nswbands + write(iulog,*) idx_sw_diag + write(iulog,*) idx_nir_diag + write(iulog,*) idx_uv_diag + write(iulog,*) idx_sw_cloudsim + write(iulog,*) idx_lw_diag + write(iulog,*) idx_lw_cloudsim + +end subroutine rrtmgp_inputs_cam_init + +!========================================================================================= + +subroutine 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) + + ! 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 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 + real(r8), intent(in) :: coszrs(:) ! cosine of solar zenith angle + class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! spectral information + + 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 + + ! local variables + integer :: i, k, iband + + real(r8) :: tref_min, tref_max + + character(len=*), parameter :: sub='rrtmgp_set_state' + character(len=512) :: errmsg + !-------------------------------------------------------------------------------- + + 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 + + ! 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:) + + ! Add extra layer values if needed. + if (nlay == pverp) then + t_rad(:,1) = state%t(: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 + + ! next interface down in LT will always be > 1Pa + ! but in MT we apply adjustment to have it be 1.02 Pa if it was too high + where (pint_rad(:,2) <= pint_rad(:,1)) pint_rad(:,2) = pint_rad(:,1)+0.01_r8 + + ! set the highest pmid (in the "extra layer") to the midpoint (guarantees > 1Pa) + pmid_rad(:,1) = pint_rad(:,1) + 0.5_r8 * (pint_rad(:,2) - pint_rad(:,1)) + + ! For case of CAM MT, also ensure pint_rad(:,2) > pint_rad(:,1) & pmid_rad(:,2) > max(pmid_rad(:,1), min_pressure) + where (pmid_rad(:,2) <= kdist_sw%get_press_min()) pmid_rad(:,2) = pint_rad(:,2) + 0.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 + + ! Limit temperatures to be within the limits of RRTMGP validity. + tref_min = kdist_sw%get_temp_min() + tref_max = kdist_sw%get_temp_max() + t_rad = merge(t_rad, tref_min, t_rad > tref_min) + t_rad = merge(t_rad, tref_max, t_rad < tref_max) + t_sfc = merge(t_sfc, tref_min, t_sfc > tref_min) + t_sfc = merge(t_sfc, tref_max, t_sfc < tref_max) + + ! Construct arrays containing only daylight 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 + + ! 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 based on a dividing line of + ! 0.7 micron, or 14286 cm^-1 + do iband = 1,nswbands + 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 + 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(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)) + 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_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 + + ! 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 + +!========================================================================================= + +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 + ! This function doesn't distinquish between visible and UV. + + ! wavenumber in inverse cm (cm^-1) + real(r8), intent(in) :: wavenumber + + ! 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 + 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 + + ! 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 = amdw + case ('CO2') + massratio = amdc + case ('O3') + massratio = amdo + case ('CH4') + massratio = amdm + case ('N2O') + massratio = amdn + case ('O2') + massratio = amdo2 + case ('CFC11') + massratio = amdc1 + case ('CFC12') + massratio = amdc2 + case default + call endrun(sub//": Invalid gas: "//trim(gas_name)) + end select + +end function get_molar_mass_ratio + +!========================================================================================= + +subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, gas_concs, ktoprad, ktopcam, idxday) + + ! 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 + 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) :: ktoprad + integer, intent(in) :: ktopcam + + 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 variables + integer :: i, idx(numactivecols) + integer :: istat + real(r8), pointer :: gas_mmr(:,:) + real(r8), allocatable :: gas_vmr(:,:) + real(r8), allocatable :: mmr(:,:) + real(r8) :: massratio + + ! 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 + 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), 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:) + 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 + + ! 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. + massratio = get_molar_mass_ratio(gas_name) + gas_vmr = mmr * massratio + + ! 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 + P_top = 50.0_r8 + do i = 1, numactivecols + 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 = log(P_int/P_top) + beta = log(P_mid/P_int)/log(P_mid/P_top) + + a = ( (1._r8 + alpha) * exp(-alpha) - 1._r8 ) / alpha + b = 1._r8 - exp(-alpha) + + 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 + end if + end do + end if + + 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)) + end if + + deallocate(gas_vmr) + deallocate(mmr) + +end subroutine rad_gas_get_vmr + +!================================================================================================== + +subroutine rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs, ktoprad, ktopcam) + + ! 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 + ! 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) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: nlay + type(ty_gas_concs), intent(inout) :: gas_concs + integer, intent(in) :: ktoprad + integer, intent(in) :: ktopcam + + ! local variables + integer :: i, ncol + character(len=*), parameter :: sub = 'rrtmgp_set_gases_lw' + !-------------------------------------------------------------------------------- + + ncol = state%ncol + do i = 1, nradgas + call rad_gas_get_vmr(icall, gaslist(i), state, pbuf, nlay, ncol, gas_concs, ktoprad, ktopcam) + end do +end subroutine rrtmgp_set_gases_lw + +!================================================================================================== + +subroutine rrtmgp_set_gases_sw( & + icall, state, pbuf, nlay, nday, & + idxday, ktoprad, ktopcam, gas_concs) + + ! Return gas_concs with gas volume mixing ratio on DAYLIT columns. + ! Set all gases in radconstants gaslist. + + ! arguments + integer, intent(in) :: icall ! index of climate/diagnostic radiation call + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: nlay + integer, intent(in) :: nday + integer, intent(in) :: idxday(:) + integer, intent(in) :: ktoprad + integer, intent(in) :: ktopcam + type(ty_gas_concs), intent(inout) :: gas_concs + + ! local variables + integer :: i + character(len=*), parameter :: sub = 'rrtmgp_set_gases_sw' + !---------------------------------------------------------------------------- + + ! 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, ktoprad, ktopcam, idxday=idxday) + end do + +end subroutine rrtmgp_set_gases_sw + +!================================================================================================== + +subroutine rrtmgp_set_cloud_lw( & + state, pbuf, ncol, nlay, nlaycam, ktoprad, ktopcam, & + 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 + 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 + integer, intent(in) :: ktoprad + integer, intent(in) :: ktopcam + 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 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) + + ! Local variables + + 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) + 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) :: 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' + !-------------------------------------------------------------------------------- + + ! 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,:,:) + + ! Extract just the layers of CAM where RRTMGP does calculations. + + ! 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:) + + ! 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 ) + + 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 + + ! Set the properties on g-points. + do i = 1, nlwgpts + cloud_lw%tau(:,ktoprad:,i) = taucmcl(i,:,:) + 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 + +end subroutine rrtmgp_set_cloud_lw + +!================================================================================================== + +subroutine rrtmgp_set_cloud_sw( & + state, pbuf, nlay, nday, idxday, ktoprad, ktopcam, & + 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. + + ! arguments + 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) :: 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 + integer, intent(in) :: ktoprad + integer, intent(in) :: ktopcam + + real(r8), intent(in) :: pmid(nday,nlay)! pressure at layer midpoints (Pa) used to seed RNG. + + 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 ! 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 :: 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 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 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 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 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 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 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. + + ! Arrays for converting from CAM chunks to RRTMGP inputs. + 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(:,:,:) + 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' + !-------------------------------------------------------------------------------- + + 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._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) & + + 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,:,:) + + ! 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), 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. + 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 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, & + 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. + 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,:,:) + 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]. + 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 + + ! 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 + +!================================================================================================== + +subroutine rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw, ktoprad, ktopcam) + + ! 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(:) + integer, intent(in) :: ktoprad + integer, intent(in) :: ktopcam + + type(ty_optical_props_1scl), intent(inout) :: aer_lw + + ! 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)) + end if +end subroutine rrtmgp_set_aer_lw + +!================================================================================================== + +subroutine rrtmgp_set_aer_sw( & + icall, state, pbuf, nday, idxday, nnite, idxnite, aer_sw, ktoprad, ktopcam) + + ! Load SW 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(:) + 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 + integer, intent(in) :: ktoprad + integer, intent(in) :: ktopcam + + type(ty_optical_props_2str), intent(inout) :: aer_sw + + ! local variables + integer :: i + + ! 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' + !-------------------------------------------------------------------------------- + + ! 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) + + ! 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) + + 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) + + end if + +end subroutine rrtmgp_set_aer_sw + +!================================================================================================== + +end module rrtmgp_inputs_cam diff --git a/src/utils/cam_ccpp/machine.F90 b/src/utils/cam_ccpp/machine.F90 new file mode 100644 index 0000000000..4d1a37e4ad --- /dev/null +++ b/src/utils/cam_ccpp/machine.F90 @@ -0,0 +1,12 @@ +! This module is the CAM version of the CCPP generated module of the same name +module machine + + use ccpp_kinds, only: kind_phys => kind_phys + + + implicit none + private + + public kind_phys + +end module machine From eb8cc7ca4ddc086617479383dfdbab223a1d07bf Mon Sep 17 00:00:00 2001 From: peverwhee Date: Thu, 27 Feb 2025 15:32:01 -0700 Subject: [PATCH 02/17] rrtmgp_inputs incorporation validated --- src/physics/rrtmgp/rad_solar_var.F90 | 13 +- src/physics/rrtmgp/radconstants.F90 | 92 ++-------- src/physics/rrtmgp/radiation.F90 | 208 ++++------------------ src/physics/rrtmgp/rrtmgp_inputs.F90 | 135 +++----------- src/physics/rrtmgp/rrtmgp_inputs_cam.F90 | 216 ++--------------------- src/physics/rrtmgp/rrtmgp_pre.F90 | 59 +++++++ 6 files changed, 155 insertions(+), 568 deletions(-) create mode 100644 src/physics/rrtmgp/rrtmgp_pre.F90 diff --git a/src/physics/rrtmgp/rad_solar_var.F90 b/src/physics/rrtmgp/rad_solar_var.F90 index 2c7888919d..de09ad84a4 100644 --- a/src/physics/rrtmgp/rad_solar_var.F90 +++ b/src/physics/rrtmgp/rad_solar_var.F90 @@ -7,7 +7,7 @@ module rad_solar_var use shr_kind_mod , only : r8 => shr_kind_r8 - use radconstants, only : nswbands, get_sw_spectral_boundaries + use radiation_utils, only : get_sw_spectral_boundaries_ccpp 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 @@ -29,10 +29,12 @@ module rad_solar_var contains !------------------------------------------------------------------------------- - subroutine rad_solar_var_init( ) + subroutine rad_solar_var_init(nswbands) + integer, intent(in) :: nswbands - integer :: ierr + integer :: ierr, errflg integer :: radmax_loc + character(len=512) :: errmsg if ( do_spctrl_scaling ) then @@ -55,7 +57,7 @@ subroutine rad_solar_var_init( ) call endrun('rad_solar_var_init: Error allocating space for irrad') end if - call get_sw_spectral_boundaries(radbinmin, radbinmax, 'nm') + call get_sw_spectral_boundaries_ccpp(radbinmin, radbinmax, 'nm', errmsg, errflg) ! Make sure that the far-IR is included, even if radiation grid does not ! extend that far down. 10^5 nm corresponds to a wavenumber of @@ -70,12 +72,13 @@ end subroutine rad_solar_var_init !------------------------------------------------------------------------------- !------------------------------------------------------------------------------- - subroutine get_variability(toa_flux, sfac, band2gpt_sw) + subroutine get_variability(toa_flux, sfac, band2gpt_sw, nswbands) ! Arguments real(r8), intent(in) :: toa_flux(:,:) ! TOA flux to be scaled (columns,gpts) real(r8), intent(out) :: sfac(:,:) ! scaling factors (columns,gpts) integer, intent(in) :: band2gpt_sw(:,:) + integer, intent(in) :: nswbands ! Local variables integer :: i, j, istat, gpt_start, gpt_end, ncols diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index e89685e04f..dd13caa397 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -31,16 +31,11 @@ module radconstants ! First and last g-point for each band. integer, public, protected :: band2gpt_sw(2,nswbands) -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 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 spectra) ! These names are recognized by RRTMGP. They are in the coefficients files as @@ -55,7 +50,7 @@ module radconstants real(r8), public, parameter :: minmmr(nradgas) = epsilon(1._r8) public :: & - set_wavenumber_bands, & + radconstants_init, & get_sw_spectral_boundaries, & get_lw_spectral_boundaries, & get_band_index_by_value, & @@ -64,79 +59,18 @@ module radconstants !========================================================================================= contains !========================================================================================= - -subroutine set_wavenumber_bands(kdist_sw, kdist_lw) - - ! Set the low and high limits of the wavenumber grid for sw and lw. - ! 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 - type(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw - - ! Local variables - integer :: istat - real(r8), allocatable :: values(:,:) - - character(len=128) :: errmsg - character(len=*), parameter :: sub = 'set_wavenumber_bands' - !---------------------------------------------------------------------------- - - ! 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 - - nswgpts = kdist_sw%get_ngpt() - nlwgpts = kdist_lw%get_ngpt() - - ! SW band bounds in cm^-1 - 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,:) - - ! First and last g-point for each SW band: - band2gpt_sw = kdist_sw%get_band_lims_gpoint() - - ! 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), 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,:) - - ! 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 radconstants_init(idx_sw_diag_in, idx_nir_diag_in, idx_uv_diag_in, idx_lw_diag_in) + integer, intent(in) :: idx_sw_diag_in + integer, intent(in) :: idx_nir_diag_in + integer, intent(in) :: idx_uv_diag_in + integer, intent(in) :: idx_lw_diag_in + + idx_sw_diag = idx_sw_diag_in + idx_nir_diag = idx_nir_diag_in + idx_uv_diag = idx_uv_diag_in + idx_lw_diag = idx_lw_diag_in + +end subroutine radconstants_init !========================================================================================= subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 6c11913219..393a146848 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -23,7 +23,7 @@ module radiation use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, rad_cnst_get_gas, rad_cnst_out use radconstants, only: nradgas, gasnamelength, nswbands, nlwbands, & - gaslist + gaslist, radconstants_init use rad_solar_var, only: rad_solar_var_init, get_variability use cloud_rad_props, only: cloud_rad_props_init @@ -153,8 +153,8 @@ module radiation ! chunk_column_index = IdxDay(daylight_column_index) integer :: nday ! Number of daylight columns integer :: nnite ! Number of night columns -integer :: idxday(pcols) = 0 ! chunk indices of daylight columns -integer :: idxnite(pcols)= 0 ! chunk indices of night columns +integer :: idxday(pcols) ! chunk indices of daylight columns +integer :: idxnite(pcols) ! chunk indices of night columns real(r8) :: coszrs(pcols) ! Cosine solar zenith angle real(r8) :: eccf ! Earth orbit eccentricity factor @@ -465,8 +465,6 @@ subroutine radiation_init(pbuf2d) ! -- needed for the kdist initialization routines type(ty_gas_concs) :: available_gases - real(r8) :: sw_low_bounds(nswbands) - real(r8) :: lw_low_bounds(nswbands) real(r8) :: qrl_unused(1,1) integer :: i, icall @@ -505,25 +503,14 @@ subroutine radiation_init(pbuf2d) nlwbands, nradgas, gasnamelength, iulog, idx_sw_diag, idx_nir_diag, idx_uv_diag, & idx_sw_cloudsim, idx_lw_diag, idx_lw_cloudsim, gaslist, nswgpts, nlwgpts, nlayp, & nextsw_cday, get_curr_calday(), band2gpt_sw, errmsg, errflg) - write(iulog,*) 'peverwhee - after init' - write(iulog,*) ktopcam - write(iulog,*) ktoprad - write(iulog,*) sw_low_bounds - write(iulog,*) sw_high_bounds - write(iulog,*) nswbands - write(iulog,*) idx_sw_diag - write(iulog,*) idx_nir_diag - write(iulog,*) idx_uv_diag - write(iulog,*) idx_sw_cloudsim - write(iulog,*) idx_lw_diag - write(iulog,*) idx_lw_cloudsim - if (errflg /= 0) then - call endrun(sub//': '//errmsg) - end if + + call rrtmgp_inputs_cam_init(ktopcam, ktoprad, idx_sw_diag, idx_nir_diag, idx_uv_diag, idx_sw_cloudsim, idx_lw_diag, & idx_lw_cloudsim) - call rad_solar_var_init() + call radconstants_init(idx_sw_diag, idx_nir_diag, idx_uv_diag, idx_lw_diag) + + call rad_solar_var_init(nswbands) ! initialize output fields for offline driver call rad_data_init(pbuf2d) @@ -862,7 +849,8 @@ subroutine radiation_tend( & use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz - use rrtmgp_inputs, only: rrtmgp_inputs_timestep_init, rrtmgp_inputs_run + use rrtmgp_inputs, only: rrtmgp_inputs_run + use rrtmgp_pre, only: rrtmgp_pre_run use rrtmgp_inputs_cam, only: rrtmgp_set_gases_lw, rrtmgp_set_cloud_lw, & rrtmgp_set_aer_lw, rrtmgp_set_gases_sw, rrtmgp_set_cloud_sw, & @@ -1023,9 +1011,6 @@ subroutine radiation_tend( & write_output = .true. end if - 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() call get_rlat_all_p(lchnk, ncol, clat) @@ -1046,26 +1031,11 @@ subroutine radiation_tend( & end do end if - ! Gather night/day column indices. - nday = 0 - nnite = 0 - idxday = 0 - idxnite = 0 - do i = 1, ncol - if ( coszrs(i) > 0.0_r8 ) then - nday = nday + 1 - idxday(nday) = i - write(iulog,*) 'peverwhee - adding new daylight point' - else - nnite = nnite + 1 - idxnite(nnite) = i - end if - end do - !call rrtmgp_inputs_timestep_init(coszrs, get_nstep(), iradsw, iradlw, irad_always, & - ! ncol, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) - !if (errflg /= 0) then - ! call endrun(sub//': '//errmsg) - !end if + call rrtmgp_pre_run(coszrs, get_nstep(), iradsw, iradlw, irad_always, & + ncol, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if ! Associate pointers to physics buffer fields itim_old = pbuf_old_tim_idx() @@ -1134,57 +1104,27 @@ subroutine radiation_tend( & stat=istat) call handle_allocate_error(istat, sub, 't_sfc,..,alb_dif') - if (masterproc) then - write(iulog,*) 'peverwhee - set state inputs' - write(iulog,*) nday - write(iulog,*) nlay - write(iulog,*) idxday - write(iulog,*) coszrs - end if - - ! Prepares state variables, daylit columns, albedos for RRTMGP ! Also calculates modified cloud fraction - !call rrtmgp_inputs_run(dosw, dolw, state%pmid, state%pint, state%t, & - ! nday, idxday, cldfprime, 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, cam_in%lwup, stebol, & - ! ncol, ktopcam, ktoprad, nswbands, cam_in%asdir, cam_in%asdif, & - ! sw_low_bounds, sw_high_bounds, cam_in%aldir, cam_in%aldif, nlay, & - ! pverp, pver, cld, cldfsnow, cldfgrau, graupel_in_rad, & - ! gasnamelength, gaslist, gas_concs_lw, aer_lw, atm_optics_lw, & - ! kdist_lw, sources_lw, aer_sw, atm_optics_sw, gas_concs_sw, & - ! errmsg, errflg) - - ! Prepares state variables, daylit columns, albedos for RRTMGP - ! rrtmgp_pre - 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) - - write(iulog,*) 'peverwhee - after set state' - write(iulog,*) t_sfc(1) - write(iulog,*) emis_sfc(1,1) - write(iulog,*) t_rad(1,1) - write(iulog,*) pmid_rad(1,1) - write(iulog,*) pint_rad(1,1) - write(iulog,*) t_day(1,1) - write(iulog,*) pmid_day(1,1) - write(iulog,*) pint_day(1,1) - write(iulog,*) coszrs_day(1) - write(iulog,*) alb_dir(1,1) - write(iulog,*) alb_dir(1,1) + call rrtmgp_inputs_run(dosw, dolw, associated(cldfsnow), associated(cldfgrau), & + state%pmid, state%pint, state%t, & + nday, idxday, cldfprime, 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, cam_in%lwup, stebol, & + ncol, ktopcam, ktoprad, nswbands, cam_in%asdir, cam_in%asdif, & + sw_low_bounds, sw_high_bounds, cam_in%aldir, cam_in%aldif, nlay, & + pverp, pver, cld, cldfsnow, cldfgrau, graupel_in_rad, & + gasnamelength, gaslist, gas_concs_lw, aer_lw, atm_optics_lw, & + kdist_lw, sources_lw, aer_sw, atm_optics_sw, gas_concs_sw, & + errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if ! 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 - ! rrtmgp_pre - call modified_cloud_fraction(ncol, cld, cldfsnow, cldfgrau, cldfprime) - !========================! ! SHORTWAVE calculations ! !========================! @@ -1193,7 +1133,7 @@ subroutine radiation_tend( & ! Set cloud optical properties in cloud_sw object. call rrtmgp_set_cloud_sw( & - state, pbuf, nlay, nday, idxday, ktoprad, ktopcam, & + state, pbuf, nlay, nday, idxday, nswgpts, & 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, & @@ -1204,25 +1144,6 @@ subroutine radiation_tend( & call radiation_output_cld(lchnk, rd) end if - ! If no daylight columns, can't create empty RRTMGP objects - if (nday > 0) then - - ! Initialize object for gas concentrations. - errmsg = gas_concs_sw%init(gaslist_lc) - 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) - 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()) - call stop_on_err(errmsg, sub, 'aer_sw%alloc_2str') - - end if - ! The climate (icall==0) calculation must occur last. do icall = N_DIAG, 0, -1 if (active_calls(icall)) then @@ -1232,7 +1153,7 @@ subroutine radiation_tend( & ! Set gas volume mixing ratios for this call in gas_concs_sw. call rrtmgp_set_gases_sw( & icall, state, pbuf, nlay, nday, & - idxday, ktoprad, ktopcam, gas_concs_sw) + idxday, gas_concs_sw) ! Compute the gas optics (stored in atm_optics_sw). ! toa_flux is the reference solar source from RRTMGP data. @@ -1242,7 +1163,7 @@ subroutine radiation_tend( & call stop_on_err(errmsg, sub, 'kdist_sw%gas_optics') ! Scale the solar source - call get_variability(toa_flux, sfac, band2gpt_sw) + call get_variability(toa_flux, sfac, band2gpt_sw, nswbands) toa_flux = toa_flux * sfac * eccf end if @@ -1251,7 +1172,7 @@ subroutine radiation_tend( & ! 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, ktoprad, ktopcam) + icall, state, pbuf, nday, idxday, nnite, idxnite, aer_sw) if (nday > 0) then @@ -1299,35 +1220,19 @@ subroutine radiation_tend( & if (dolw) then - ! Initialize object for Planck sources. - errmsg = sources_lw%alloc(ncol, nlay, kdist_lw) - call stop_on_err(errmsg, sub, 'sources_lw%alloc') - ! Set cloud optical properties in cloud_lw object. call rrtmgp_set_cloud_lw( & - state, pbuf, ncol, nlay, nlaycam, ktoprad, ktopcam, & + state, pbuf, ncol, nlay, nlaycam, nlwgpts, & 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) - 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) - 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()) - call stop_on_err(errmsg, sub, 'aer_lw%alloc_1scl') - ! 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_lw. - call rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs_lw, ktoprad, ktopcam) + call rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs_lw) ! Compute the gas optics and Planck sources. errmsg = kdist_lw%gas_optics( & @@ -1336,7 +1241,7 @@ subroutine radiation_tend( & 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, ktoprad, ktopcam) + 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) @@ -2511,47 +2416,6 @@ end subroutine free_fluxes !========================================================================================= -subroutine modified_cloud_fraction(ncol, cld, cldfsnow, cldfgrau, cldfprime) - - ! Compute modified cloud fraction, cldfprime. - ! 1. initialize as cld - ! 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) - - ! 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 - - ! 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 - end do - else - cldfprime(:ncol,:) = cld(:ncol,:) - end if - - 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 - end do - end if - -end subroutine modified_cloud_fraction - -!========================================================================================= - subroutine stop_on_err(errmsg, sub, info) ! call endrun if RRTMGP function returns non-empty error message. diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index c62f8433e9..58e6be5258 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -6,60 +6,15 @@ module rrtmgp_inputs use mo_source_functions, only: ty_source_func_lw use string_utils, only: to_lower use radiation_utils, only: radiation_utils_init, get_sw_spectral_boundaries_ccpp + use cam_logfile, only: iulog implicit none private - public :: rrtmgp_inputs_register - public :: rrtmgp_inputs_timestep_init public :: rrtmgp_inputs_init public :: rrtmgp_inputs_run contains -!> \section arg_table_rrtmgp_inputs_register Argument Table -!! \htmlinclude rrtmgp_inputs_register.html -!! - subroutine rrtmgp_inputs_register(gaslist, nradgas, gasnamelength, errmsg, errflg) -! use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - ! Inputs - character(len=*), intent(in) :: gaslist(:) - integer, intent(in) :: nradgas - integer, intent(in) :: gasnamelength - ! Outputs - ! type(ccpp_constituent_properties_t), allocatable, intent(out) :: const_props(:) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: gas_index - real(kind_phys) :: minmmr - - ! Set error variables - errflg = 0 - errmsg = '' - ! Set minimum mass mixing ratio supported by radiation implementation - minmmr = epsilon(1._kind_phys) - ! Register all gases in gaslist - ! peverwhee - compare vs rad_constituents! - ! do gas_index = 1, ndradgas - ! call const_props(gas_index)%instantiate( & - ! std_name = gaslist(gas_index), & - ! long_name = gaslist(gas_index), & - ! units = 'kg-1', & - ! vertical_dim = 'vertical_layer_dimension', & - ! min_value = minmmr, & - ! advected = .false., & - ! water_species = .false., & - ! mixing_ratio_type = 'dry', & - ! errcode = errflg, & - ! errmsg = errmsg) - ! if (errflg /= 0) then - ! return - ! end if - ! end do - - - end subroutine rrtmgp_inputs_register !> \section arg_table_rrtmgp_inputs_init Argument Table !! \htmlinclude rrtmgp_inputs_init.html !! @@ -205,62 +160,11 @@ subroutine rrtmgp_inputs_init(ktopcam, ktoprad, nlaycam, sw_low_bounds, sw_high_ end subroutine rrtmgp_inputs_init -!> \section arg_table_rrtmgp_inputs_timestep_init Argument Table -!! \htmlinclude rrtmgp_inputs_timestep_init.html -!! - subroutine rrtmgp_inputs_timestep_init(coszrs, nstep, iradsw, iradlw, irad_always, & - ncol, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - real(kind_phys), dimension(:), intent(in) :: coszrs - integer, intent(in) :: nstep - integer, intent(in) :: iradsw - integer, intent(in) :: iradlw - integer, intent(in) :: irad_always - integer, intent(in) :: ncol - integer, intent(out) :: nday - integer, intent(out) :: nnite - integer, dimension(:), intent(out) :: idxday - integer, dimension(:), intent(out) :: idxnite - logical, intent(out) :: dosw - logical, intent(out) :: dolw - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: idx - - ! Set error variables - errflg = 0 - errmsg = '' - - ! Gather night/day column indices. - nday = 0 - nnite = 0 - do idx = 1, ncol - if ( coszrs(idx) > 0.0_kind_phys ) then - nday = nday + 1 - idxday(nday) = idx - else - nnite = nnite + 1 - idxnite(nnite) = idx - end if - end do - - ! Determine if we're going to do longwave and/or shortwave this timestep - dosw = nstep == 0 .or. iradsw == 1 & - .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - - dolw = nstep == 0 .or. iradlw == 1 & - .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - - end subroutine rrtmgp_inputs_timestep_init - !> \section arg_table_rrtmgp_inputs_run Argument Table !! \htmlinclude rrtmgp_inputs_run.html !! - subroutine rrtmgp_inputs_run(dosw, dolw, pmid, pint, t, nday, idxday, cldfprime, & + subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & + pmid, pint, t, nday, idxday, cldfprime, & 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, lwup, stebol, ncol, ktopcam, ktoprad, & @@ -283,6 +187,8 @@ subroutine rrtmgp_inputs_run(dosw, dolw, pmid, pint, t, nday, idxday, cldfprime, integer, intent(in) :: nday logical, intent(in) :: dosw logical, intent(in) :: dolw + logical, intent(in) :: snow_associated + logical, intent(in) :: graupel_associated integer, dimension(:), intent(in) :: idxday real(kind_phys), dimension(:,:), intent(in) :: pmid real(kind_phys), dimension(:,:), intent(in) :: pint @@ -385,8 +291,6 @@ subroutine rrtmgp_inputs_run(dosw, dolw, pmid, pint, t, nday, idxday, cldfprime, tref_max = kdist_sw%get_temp_max() t_rad = merge(t_rad, tref_min, t_rad > tref_min) t_rad = merge(t_rad, tref_max, t_rad < tref_max) - t_sfc = merge(t_sfc, tref_min, t_sfc > tref_min) - t_sfc = merge(t_sfc, tref_max, t_sfc < tref_max) ! Construct arrays containing only daylight columns do idx = 1, nday @@ -395,7 +299,6 @@ subroutine rrtmgp_inputs_run(dosw, dolw, pmid, pint, t, nday, idxday, cldfprime, pint_day(idx,:) = pint_rad(idxday(idx),:) coszrs_day(idx) = coszrs(idxday(idx)) end do - ! 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 @@ -430,6 +333,19 @@ subroutine rrtmgp_inputs_run(dosw, dolw, pmid, pint, t, nday, idxday, cldfprime, end do end if end do + ! Strictly enforce albedo bounds + where (alb_dir < 0) + alb_dir = 0.0_kind_phys + end where + where (alb_dir > 1) + alb_dir = 1.0_kind_phys + end where + where (alb_dif < 0) + alb_dif = 0.0_kind_phys + end where + where (alb_dif > 1) + alb_dif = 1.0_kind_phys + end where ! modified cloud fraction ! Compute modified cloud fraction, cldfprime. @@ -437,13 +353,17 @@ subroutine rrtmgp_inputs_run(dosw, dolw, pmid, pint, t, nday, idxday, cldfprime, ! 2. modify for snow. use max(cld, cldfsnow) ! 3. modify for graupel if graupel_in_rad is true. ! use max(cldfprime, cldfgrau) - do kdx = 1, pver - do idx = 1, ncol - cldfprime(idx,kdx) = max(cld(idx,kdx), cldfsnow(idx,kdx)) + if (snow_associated) then + do kdx = 1, pver + do idx = 1, ncol + cldfprime(idx,kdx) = max(cld(idx,kdx), cldfsnow(idx,kdx)) + end do end do - end do + else + cldfprime(:ncol,:) = cld(:ncol,:) + end if - if (graupel_in_rad) then + if (graupel_associated .and. graupel_in_rad) then do kdx = 1, pver do idx = 1, ncol cldfprime(idx,kdx) = max(cldfprime(idx,kdx), cldfgrau(idx,kdx)) @@ -514,7 +434,6 @@ subroutine rrtmgp_inputs_run(dosw, dolw, pmid, pint, t, nday, idxday, cldfprime, end if end if - end subroutine rrtmgp_inputs_run !========================================================================================= diff --git a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 index 270fe68ca1..934b3599c0 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 @@ -17,7 +17,7 @@ module rrtmgp_inputs_cam use physics_buffer, only: physics_buffer_desc use camsrfexch, only: cam_in_t -use radconstants, only: nradgas, gaslist, nswbands, nlwbands, nswgpts, nlwgpts +use radconstants, only: nradgas, gaslist, nswbands, nlwbands use rad_constituents, only: rad_cnst_get_gas @@ -45,7 +45,6 @@ module rrtmgp_inputs_cam save public :: & - rrtmgp_set_state, & rrtmgp_inputs_cam_init, & rrtmgp_set_gases_lw, & rrtmgp_set_gases_sw, & @@ -108,190 +107,11 @@ subroutine rrtmgp_inputs_cam_init(ktcam, ktrad, idx_sw_diag_in, idx_nir_diag_in, ! Initialize the module data containing the SW band boundaries. call get_sw_spectral_boundaries_ccpp(sw_low_bounds, sw_high_bounds, 'cm^-1', errmsg, errflg) - write(iulog,*) 'peverwhee - after cam init' - write(iulog,*) ktopcam - write(iulog,*) ktoprad - write(iulog,*) sw_low_bounds - write(iulog,*) sw_high_bounds - write(iulog,*) nswbands - write(iulog,*) idx_sw_diag - write(iulog,*) idx_nir_diag - write(iulog,*) idx_uv_diag - write(iulog,*) idx_sw_cloudsim - write(iulog,*) idx_lw_diag - write(iulog,*) idx_lw_cloudsim end subroutine rrtmgp_inputs_cam_init !========================================================================================= -subroutine 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) - - ! 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 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 - real(r8), intent(in) :: coszrs(:) ! cosine of solar zenith angle - class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! spectral information - - 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 - - ! local variables - integer :: i, k, iband - - real(r8) :: tref_min, tref_max - - character(len=*), parameter :: sub='rrtmgp_set_state' - character(len=512) :: errmsg - !-------------------------------------------------------------------------------- - - 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 - - ! 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:) - - ! Add extra layer values if needed. - if (nlay == pverp) then - t_rad(:,1) = state%t(: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 - - ! next interface down in LT will always be > 1Pa - ! but in MT we apply adjustment to have it be 1.02 Pa if it was too high - where (pint_rad(:,2) <= pint_rad(:,1)) pint_rad(:,2) = pint_rad(:,1)+0.01_r8 - - ! set the highest pmid (in the "extra layer") to the midpoint (guarantees > 1Pa) - pmid_rad(:,1) = pint_rad(:,1) + 0.5_r8 * (pint_rad(:,2) - pint_rad(:,1)) - - ! For case of CAM MT, also ensure pint_rad(:,2) > pint_rad(:,1) & pmid_rad(:,2) > max(pmid_rad(:,1), min_pressure) - where (pmid_rad(:,2) <= kdist_sw%get_press_min()) pmid_rad(:,2) = pint_rad(:,2) + 0.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 - - ! Limit temperatures to be within the limits of RRTMGP validity. - tref_min = kdist_sw%get_temp_min() - tref_max = kdist_sw%get_temp_max() - t_rad = merge(t_rad, tref_min, t_rad > tref_min) - t_rad = merge(t_rad, tref_max, t_rad < tref_max) - t_sfc = merge(t_sfc, tref_min, t_sfc > tref_min) - t_sfc = merge(t_sfc, tref_max, t_sfc < tref_max) - - ! Construct arrays containing only daylight 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 - - ! 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 based on a dividing line of - ! 0.7 micron, or 14286 cm^-1 - do iband = 1,nswbands - 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 - 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(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)) - 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_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 - - ! 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 - -!========================================================================================= - -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 - ! This function doesn't distinquish between visible and UV. - - ! wavenumber in inverse cm (cm^-1) - real(r8), intent(in) :: wavenumber - - ! 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 - 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 @@ -337,7 +157,7 @@ end function get_molar_mass_ratio !========================================================================================= -subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, gas_concs, ktoprad, ktopcam, idxday) +subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, gas_concs, idxday) ! Set volume mixing ratio in gas_concs object. ! The gas_concs%set_vmr method copies data into internally allocated storage. @@ -348,8 +168,6 @@ subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, ga 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) :: ktoprad - integer, intent(in) :: ktopcam type(ty_gas_concs), intent(inout) :: gas_concs ! the result is VRM inside gas_concs @@ -446,7 +264,7 @@ end subroutine rad_gas_get_vmr !================================================================================================== -subroutine rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs, ktoprad, ktopcam) +subroutine rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs) ! Set gas vmr for the gases in the radconstants module's gaslist. @@ -461,8 +279,6 @@ subroutine rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs, ktoprad, kto type(physics_buffer_desc), pointer :: pbuf(:) integer, intent(in) :: nlay type(ty_gas_concs), intent(inout) :: gas_concs - integer, intent(in) :: ktoprad - integer, intent(in) :: ktopcam ! local variables integer :: i, ncol @@ -471,7 +287,7 @@ subroutine rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs, ktoprad, kto ncol = state%ncol do i = 1, nradgas - call rad_gas_get_vmr(icall, gaslist(i), state, pbuf, nlay, ncol, gas_concs, ktoprad, ktopcam) + call rad_gas_get_vmr(icall, gaslist(i), state, pbuf, nlay, ncol, gas_concs) end do end subroutine rrtmgp_set_gases_lw @@ -479,7 +295,7 @@ end subroutine rrtmgp_set_gases_lw subroutine rrtmgp_set_gases_sw( & icall, state, pbuf, nlay, nday, & - idxday, ktoprad, ktopcam, gas_concs) + idxday, gas_concs) ! Return gas_concs with gas volume mixing ratio on DAYLIT columns. ! Set all gases in radconstants gaslist. @@ -491,8 +307,6 @@ subroutine rrtmgp_set_gases_sw( & integer, intent(in) :: nlay integer, intent(in) :: nday integer, intent(in) :: idxday(:) - integer, intent(in) :: ktoprad - integer, intent(in) :: ktopcam type(ty_gas_concs), intent(inout) :: gas_concs ! local variables @@ -502,7 +316,7 @@ subroutine rrtmgp_set_gases_sw( & ! 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, ktoprad, ktopcam, idxday=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 @@ -510,7 +324,7 @@ end subroutine rrtmgp_set_gases_sw !================================================================================================== subroutine rrtmgp_set_cloud_lw( & - state, pbuf, ncol, nlay, nlaycam, ktoprad, ktopcam, & + state, pbuf, ncol, nlay, nlaycam, nlwgpts, & cld, cldfsnow, cldfgrau, cldfprime, graupel_in_rad, & kdist_lw, cloud_lw, cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, grau_lw_abs_cloudsim) @@ -524,8 +338,7 @@ subroutine rrtmgp_set_cloud_lw( & 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 - integer, intent(in) :: ktoprad - integer, intent(in) :: ktopcam + integer, intent(in) :: nlwgpts 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" @@ -647,7 +460,7 @@ end subroutine rrtmgp_set_cloud_lw !================================================================================================== subroutine rrtmgp_set_cloud_sw( & - state, pbuf, nlay, nday, idxday, ktoprad, ktopcam, & + state, pbuf, nlay, nday, idxday, nswgpts, & 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, & @@ -663,10 +476,9 @@ subroutine rrtmgp_set_cloud_sw( & integer, intent(in) :: nlay ! number of layers in radiation calculation (may include "extra layer") integer, intent(in) :: nday ! number of daylight columns integer, intent(in) :: idxday(pcols) ! indices of daylight columns in the chunk + integer, intent(in) :: nswgpts integer, intent(in) :: nnite ! number of night columns integer, intent(in) :: idxnite(pcols) ! indices of night columns in the chunk - integer, intent(in) :: ktoprad - integer, intent(in) :: ktopcam real(r8), intent(in) :: pmid(nday,nlay)! pressure at layer midpoints (Pa) used to seed RNG. @@ -927,7 +739,7 @@ end subroutine rrtmgp_set_cloud_sw !================================================================================================== -subroutine rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw, ktoprad, ktopcam) +subroutine rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw) ! Load LW aerosol optical properties into the RRTMGP object. @@ -935,8 +747,6 @@ subroutine rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw, ktoprad, ktopcam) integer, intent(in) :: icall type(physics_state), target, intent(in) :: state type(physics_buffer_desc), pointer :: pbuf(:) - integer, intent(in) :: ktoprad - integer, intent(in) :: ktopcam type(ty_optical_props_1scl), intent(inout) :: aer_lw @@ -970,7 +780,7 @@ end subroutine rrtmgp_set_aer_lw !================================================================================================== subroutine rrtmgp_set_aer_sw( & - icall, state, pbuf, nday, idxday, nnite, idxnite, aer_sw, ktoprad, ktopcam) + icall, state, pbuf, nday, idxday, nnite, idxnite, aer_sw) ! Load SW aerosol optical properties into the RRTMGP object. @@ -982,8 +792,6 @@ subroutine rrtmgp_set_aer_sw( & integer, intent(in) :: idxday(:) integer, intent(in) :: nnite ! number of night columns integer, intent(in) :: idxnite(pcols) ! indices of night columns in the chunk - integer, intent(in) :: ktoprad - integer, intent(in) :: ktopcam type(ty_optical_props_2str), intent(inout) :: aer_sw diff --git a/src/physics/rrtmgp/rrtmgp_pre.F90 b/src/physics/rrtmgp/rrtmgp_pre.F90 new file mode 100644 index 0000000000..093115a9a8 --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_pre.F90 @@ -0,0 +1,59 @@ +module rrtmgp_pre + use ccpp_kinds, only: kind_phys + + public :: rrtmgp_pre_run + +CONTAINS + +!> \section arg_table_rrtmgp_pre_run Argument Table +!! \htmlinclude rrtmgp_pre_run.html +!! + subroutine rrtmgp_pre_run(coszrs, nstep, iradsw, iradlw, irad_always, & + ncol, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + real(kind_phys), dimension(:), intent(in) :: coszrs + integer, intent(in) :: nstep + integer, intent(in) :: iradsw + integer, intent(in) :: iradlw + integer, intent(in) :: irad_always + integer, intent(in) :: ncol + integer, intent(out) :: nday + integer, intent(out) :: nnite + integer, dimension(:), intent(out) :: idxday + integer, dimension(:), intent(out) :: idxnite + logical, intent(out) :: dosw + logical, intent(out) :: dolw + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: idx + + ! Set error variables + errflg = 0 + errmsg = '' + + ! Gather night/day column indices. + nday = 0 + nnite = 0 + do idx = 1, ncol + if ( coszrs(idx) > 0.0_kind_phys ) then + nday = nday + 1 + idxday(nday) = idx + else + nnite = nnite + 1 + idxnite(nnite) = idx + end if + end do + + ! Determine if we're going to do longwave and/or shortwave this timestep + dosw = nstep == 0 .or. iradsw == 1 & + .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + dolw = nstep == 0 .or. iradlw == 1 & + .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + end subroutine rrtmgp_pre_run + +end module rrtmgp_pre From 7a7713c2238478b755d7c63d9fd92b8551736b9f Mon Sep 17 00:00:00 2001 From: peverwhee Date: Thu, 6 Mar 2025 15:40:14 -0700 Subject: [PATCH 03/17] lw cloud optics mostly done --- src/physics/cam/cloud_rad_props.F90 | 33 +++-- src/physics/rrtmgp/radiation.F90 | 178 ++++++++++++----------- src/physics/rrtmgp/rrtmgp_inputs_cam.F90 | 25 ++-- 3 files changed, 128 insertions(+), 108 deletions(-) diff --git a/src/physics/cam/cloud_rad_props.F90 b/src/physics/cam/cloud_rad_props.F90 index 257138e7b5..b854ea5900 100644 --- a/src/physics/cam/cloud_rad_props.F90 +++ b/src/physics/cam/cloud_rad_props.F90 @@ -37,6 +37,7 @@ module cloud_rad_props get_snow_optics_sw, & snow_cloud_get_rad_props_lw, & get_grau_optics_sw, & + get_mu_lambda_weights, & grau_cloud_get_rad_props_lw @@ -83,6 +84,7 @@ subroutine cloud_rad_props_init() use spmd_utils, only: masterproc use ioFileMod, only: getfil use error_messages, only: handle_ncerr + use rrtmgp_lw_cloud_optics, only: rrtmgp_lw_cloud_optics_init #if ( defined SPMD ) use mpishorthand #endif @@ -103,6 +105,7 @@ subroutine cloud_rad_props_init() integer :: err character(len=*), parameter :: sub = 'cloud_rad_props_init' + character(len=512) :: errmsg liquidfile = liqopticsfile icefile = iceopticsfile @@ -278,6 +281,13 @@ subroutine cloud_rad_props_init() call mpibcast(abs_lw_ice, n_g_d*nlwbands, mpir8, 0, mpicom, ierr) #endif + ! Initialize ccpp modules + call rrtmgp_lw_cloud_optics_init(nmu, nlambda, n_g_d, & + abs_lw_liq, abs_lw_ice, nlwbands, g_mu, g_lambda, & + g_d_eff, tiny, errmsg, err) + if (err /= 0) then + call endrun(sub//': rrtmgp_lw_cloud_optics_init failed: '//errmsg) + end if return end subroutine cloud_rad_props_init @@ -728,28 +738,21 @@ end subroutine gam_liquid_sw !============================================================================== subroutine get_mu_lambda_weights(lamc, pgam, mu_wgts, lambda_wgts) + use radiation_utils, only: get_mu_lambda_weights_ccpp 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 + character(len=512) :: errmsg + integer :: errflg - ! Make interpolation weights for lambda. - call lininterp_init(g_lambda_interp, nlambda, [lamc], 1, & - extrap_method_bndry, lambda_wgts) + call get_mu_lambda_weights_ccpp(nmu, nlambda, g_mu, g_lambda, lamc, pgam, mu_wgts, & + lambda_wgts, errmsg, errflg) + if (errflg /= 0) then + call endrun('get_mu_lambda_weights: ERROR message: '//errmsg) + end if end subroutine get_mu_lambda_weights diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 393a146848..b1062872b5 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -56,6 +56,7 @@ module radiation use string_utils, only: to_lower use cam_abortutils, only: endrun, handle_allocate_error use cam_logfile, only: iulog +use rrtmgp_pre, only: radiation_do_ccpp implicit none @@ -64,8 +65,8 @@ module radiation public :: & radiation_readnl, &! read namelist variables - radiation_register, &! registers radiation physics buffer fields radiation_do, &! query which radiation calcs are done this timestep + radiation_register, &! registers radiation physics buffer fields radiation_init, &! initialization radiation_define_restart, &! define variables for restart radiation_write_restart, &! write variables to restart @@ -179,6 +180,15 @@ module radiation integer :: cld_idx = 0 integer :: cldfsnow_idx = 0 integer :: cldfgrau_idx = 0 +integer :: dei_idx +integer :: mu_idx +integer :: lambda_idx +integer :: iciwp_idx +integer :: iclwp_idx +integer :: des_idx +integer :: icswp_idx +integer :: icgrauwp_idx +integer :: degrau_idx character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ',& '_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) @@ -372,33 +382,26 @@ end subroutine radiation_register !================================================================================================ -function radiation_do(op, timestep) +function radiation_do(op) ! 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 + integer :: errcode + character(len=512) :: errmsg !----------------------------------------------------------------------- - if (present(timestep)) then - nstep = timestep - else - nstep = get_nstep() - end if + nstep = get_nstep() 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 + call radiation_do_ccpp(op, nstep, iradsw, irad_always, radiation_do, errmsg, errcode) 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 + call radiation_do_ccpp(op, nstep, iradlw, irad_always, radiation_do, errmsg, errcode) case default call endrun('radiation_do: unknown operation:'//op) end select @@ -407,47 +410,6 @@ end function radiation_do !================================================================================================ -real(r8) function radiation_nextsw_cday() - - ! 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 - logical :: dosw ! true => do shosrtwave calc - integer :: offset ! offset for calendar day calculation - integer :: dtime ! integer timestep size - 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) use rrtmgp_inputs, only: rrtmgp_inputs_init use rrtmgp_inputs_cam, only: rrtmgp_inputs_cam_init @@ -527,15 +489,15 @@ subroutine radiation_init(pbuf2d) ! 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 + !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 + !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, & @@ -544,10 +506,10 @@ 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() - if (irad_always > 0) then - irad_always = irad_always + nstep - end if + !nstep = get_nstep() + !if (irad_always > 0) then + ! irad_always = irad_always + nstep + !end if if (docosp) call cospsimulator_intr_init() @@ -851,10 +813,13 @@ subroutine radiation_tend( & use rrtmgp_inputs, only: rrtmgp_inputs_run use rrtmgp_pre, only: rrtmgp_pre_run + use rrtmgp_lw_initialize_fluxes, only: rrtmgp_lw_initialize_fluxes_run + use rrtmgp_lw_cloud_optics, only: rrtmgp_lw_cloud_optics_run + use rrtmgp_lw_mcica_subcol_gen, only: rrtmgp_lw_mcica_subcol_gen_run - use rrtmgp_inputs_cam, only: rrtmgp_set_gases_lw, rrtmgp_set_cloud_lw, & + use rrtmgp_inputs_cam, only: rrtmgp_set_gases_lw, & rrtmgp_set_aer_lw, rrtmgp_set_gases_sw, rrtmgp_set_cloud_sw, & - rrtmgp_set_aer_sw, rrtmgp_set_state + rrtmgp_set_aer_sw ! RRTMGP drivers for flux calculations. use mo_rte_lw, only: rte_lw @@ -911,6 +876,16 @@ subroutine radiation_tend( & real(r8), pointer :: flns(:) ! Srf longwave cooling (up-down) flux real(r8), pointer :: flnt(:) ! Net outgoing lw flux at model top + real(r8), pointer :: dei(:,:) + real(r8), pointer :: mu(:,:) + real(r8), pointer :: lambda(:,:) + real(r8), pointer :: iciwp(:,:) + real(r8), pointer :: iclwp(:,:) + real(r8), pointer :: des(:,:) + real(r8), pointer :: icswp(:,:) + real(r8), pointer :: icgrauwp(:,:) + real(r8), pointer :: degrau(:,:) + 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 @@ -932,6 +907,8 @@ subroutine radiation_tend( & real(r8), allocatable :: coszrs_day(:) real(r8), allocatable :: alb_dir(:,:) real(r8), allocatable :: alb_dif(:,:) + real(r8), allocatable :: tauc(:,:,:) + real(r8), allocatable :: cldf(:,:) ! in-cloud optical depths for COSP real(r8) :: cld_tau_cloudsim(pcols,pver) ! liq + ice @@ -944,6 +921,8 @@ subroutine radiation_tend( & ! Set vertical indexing in RRTMGP to be the same as CAM (top to bottom). logical, parameter :: top_at_1 = .true. + logical :: do_graupel, do_snow + ! TOA solar flux on RRTMGP g-points real(r8), allocatable :: toa_flux(:,:) ! Scale factors based on spectral distribution from input irradiance dataset @@ -995,7 +974,7 @@ subroutine radiation_tend( & real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables character(len=128) :: errmsg - integer :: errflg + integer :: errflg, err character(len=*), parameter :: sub = 'radiation_tend' !-------------------------------------------------------------------------------------- @@ -1031,8 +1010,8 @@ subroutine radiation_tend( & end do end if - call rrtmgp_pre_run(coszrs, get_nstep(), iradsw, iradlw, irad_always, & - ncol, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) + call rrtmgp_pre_run(coszrs, get_nstep(), get_step_size(), iradsw, iradlw, irad_always, & + ncol, nextsw_cday, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if @@ -1069,8 +1048,11 @@ subroutine radiation_tend( & ! 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) - call initialize_rrtmgp_fluxes(ncol, nlay+1, nlwbands, flwc) + call rrtmgp_lw_initialize_fluxes_run(ncol, nlay, nlwbands, spectralflux, flw, flwc, & + errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if ! For CRM, make cloud equal to input observations: if (scm_crm_mode .and. have_cld) then @@ -1089,10 +1071,6 @@ subroutine radiation_tend( & 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 (dosw .or. dolw) then allocate( & @@ -1101,7 +1079,7 @@ subroutine radiation_tend( & 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) + cldf(ncol,nlaycam), tauc(nlwbands,ncol,nlaycam), stat=istat) call handle_allocate_error(istat, sub, 't_sfc,..,alb_dif') ! Prepares state variables, daylit columns, albedos for RRTMGP @@ -1220,11 +1198,47 @@ subroutine radiation_tend( & if (dolw) then + ! Grab additional pbuf fields for LW cloud optics + dei_idx = pbuf_get_index('DEI',errcode=err) + mu_idx = pbuf_get_index('MU',errcode=err) + lambda_idx = pbuf_get_index('LAMBDAC',errcode=err) + iciwp_idx = pbuf_get_index('ICIWP',errcode=err) + iclwp_idx = pbuf_get_index('ICLWP',errcode=err) + des_idx = pbuf_get_index('DES',errcode=err) + icswp_idx = pbuf_get_index('ICSWP',errcode=err) + icgrauwp_idx = pbuf_get_index('ICGRAUWP',errcode=err) ! Available when using MG3 + degrau_idx = pbuf_get_index('DEGRAU',errcode=err) ! Available when using MG3 + call pbuf_get_field(pbuf, lambda_idx, lambda) + call pbuf_get_field(pbuf, mu_idx, mu) + call pbuf_get_field(pbuf, iclwp_idx, iclwp) + call pbuf_get_field(pbuf, iciwp_idx, iciwp) + call pbuf_get_field(pbuf, dei_idx, dei) + call pbuf_get_field(pbuf, icswp_idx, icswp) + call pbuf_get_field(pbuf, des_idx, des) + if (icgrauwp_idx > 0) then + call pbuf_get_field(pbuf, icgrauwp_idx, icgrauwp) + end if + if (degrau_idx > 0) then + call pbuf_get_field(pbuf, degrau_idx, degrau) + end if + do_graupel = ((icgrauwp_idx > 0) .and. (degrau_idx > 0) .and. associated(cldfgrau)) + do_snow = associated(cldfsnow) ! Set cloud optical properties in cloud_lw object. - call rrtmgp_set_cloud_lw( & - state, pbuf, ncol, nlay, nlaycam, nlwgpts, & - cld, cldfsnow, cldfgrau, cldfprime, graupel_in_rad, & - kdist_lw, cloud_lw, cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, grau_lw_abs_cloudsim) + call rrtmgp_lw_cloud_optics_run(ncol, nlay, nlaycam, cld, cldfsnow, cldfgrau, & + cldfprime, graupel_in_rad, kdist_lw, cloud_lw, lambda, mu, iclwp, iciwp, & + dei, icswp, des, icgrauwp, degrau, nlwbands, do_snow, & + do_graupel, cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, pver, ktopcam, & + grau_lw_abs_cloudsim, idx_lw_cloudsim, tauc, cldf, errmsg, errflg) + + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if + call rrtmgp_lw_mcica_subcol_gen_run(ktoprad, & + kdist_lw, nlwbands, nlwgpts, ncol, pver, nlaycam, nlwgpts, & + state%pmid, cldf, tauc, cloud_lw, errmsg, errflg ) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if ! The climate (icall==0) calculation must occur last. do icall = N_DIAG, 0, -1 diff --git a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 index 934b3599c0..219ceef0e6 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 @@ -325,7 +325,7 @@ end subroutine rrtmgp_set_gases_sw subroutine rrtmgp_set_cloud_lw( & state, pbuf, ncol, nlay, nlaycam, nlwgpts, & - cld, cldfsnow, cldfgrau, cldfprime, graupel_in_rad, & + cld, cldfsnow, cldfgrau, cldfprime, graupel_in_rad, tauc, cldf, & kdist_lw, cloud_lw, cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, grau_lw_abs_cloudsim) ! Compute combined cloud optical properties. @@ -343,10 +343,12 @@ subroutine rrtmgp_set_cloud_lw( & 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 + real(r8), intent(in) :: tauc(:,:,:) + real(r8), intent(in) :: cldf(:,:) 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 + type(ty_optical_props_1scl), intent(inout) :: cloud_lw ! Diagnostic outputs real(r8), intent(out) :: cld_lw_abs_cloudsim(pcols,pver) ! in-cloud liq+ice optical depth (for COSP) @@ -366,16 +368,16 @@ 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) :: cldf(ncol,nlaycam) - real(r8) :: tauc(nlwbands,ncol,nlaycam) - real(r8) :: taucmcl(nlwgpts,ncol,nlaycam) +! real(r8) :: cldf(ncol,nlaycam) +! real(r8) :: tauc(nlwbands,ncol,nlaycam) + real(r8) :: taucmcl(nlwgpts,ncol,nlay) character(len=128) :: errmsg character(len=*), parameter :: sub = 'rrtmgp_set_cloud_lw' !-------------------------------------------------------------------------------- ! Combine the cloud optical properties. These calculations are done on CAM "chunks". - +#if 0 ! gammadist liquid optics call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) ! Mitchell ice optics @@ -429,20 +431,21 @@ subroutine rrtmgp_set_cloud_lw( & ! Enforce tauc >= 0. tauc = merge(tauc, 0.0_r8, tauc > 0.0_r8) +#endif ! 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 ) - 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 +! 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 +! cloud_lw%tau = 0.0_r8 ! Set the properties on g-points. do i = 1, nlwgpts From a17c311fb9bb465caccdd92870aea8c244fec7a1 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Thu, 6 Mar 2025 15:49:52 -0700 Subject: [PATCH 04/17] commit everything; will disentangle what goes into ccpp-physics later --- src/physics/rrtmgp/radiation_utils.F90 | 45 +- src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 | 466 ++++++++++++++++++ .../rrtmgp/rrtmgp_lw_initialize_fluxes.F90 | 180 +++++++ .../rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 | 189 +++++++ src/physics/rrtmgp/rrtmgp_pre.F90 | 91 +++- 5 files changed, 962 insertions(+), 9 deletions(-) create mode 100644 src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_lw_initialize_fluxes.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 diff --git a/src/physics/rrtmgp/radiation_utils.F90 b/src/physics/rrtmgp/radiation_utils.F90 index 69774d9895..f16ad130a3 100644 --- a/src/physics/rrtmgp/radiation_utils.F90 +++ b/src/physics/rrtmgp/radiation_utils.F90 @@ -1,9 +1,12 @@ module radiation_utils use ccpp_kinds, only: kind_phys + use interpolate_data, only: interp_type, lininterp_init, lininterp, & + extrap_method_bndry public :: radiation_utils_init public :: get_sw_spectral_boundaries_ccpp public :: get_lw_spectral_boundaries_ccpp + public :: get_mu_lambda_weights_ccpp real(kind_phys), allocatable :: wavenumber_low_shortwave(:) real(kind_phys), allocatable :: wavenumber_high_shortwave(:) @@ -151,6 +154,46 @@ subroutine get_lw_spectral_boundaries_ccpp(low_boundaries, high_boundaries, unit end select end subroutine get_lw_spectral_boundaries_ccpp - + +!========================================================================================= + +subroutine get_mu_lambda_weights_ccpp(nmu, nlambda, g_mu, g_lambda, lamc, pgam, & + mu_wgts, lambda_wgts, errmsg, errflg) + integer, intent(in) :: nmu + integer, intent(in) :: nlambda + real(kind_phys), intent(in) :: g_mu(:) + real(kind_phys), intent(in) :: g_lambda(:,:) + real(kind_phys), intent(in) :: lamc ! prognosed value of lambda for cloud + real(kind_phys), 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 + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: ilambda + real(kind_phys) :: g_lambda_interp(nlambda) + + ! Set error variables + errmsg = '' + errflg = 0 + + ! 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_ccpp + +!========================================================================================= end module radiation_utils diff --git a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 new file mode 100644 index 0000000000..663d1bca6a --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 @@ -0,0 +1,466 @@ +! PEVERWHEE - dependencies = interpolate_data +!> \file rrtmgp_lw_cloud_optics.F90 +!! + +!> This module contains two routines: The first initializes data and functions +!! needed to compute the longwave cloud radiative properteis in RRTMGP. The second routine +!! is a ccpp scheme within the "radiation loop", where the shortwave optical properties +!! (optical-depth, single-scattering albedo, asymmetry parameter) are computed for ALL +!! cloud types visible to RRTMGP. +module rrtmgp_lw_cloud_optics + use machine, only: kind_phys + use mo_rte_kind, only: wl +! use mo_cloud_optics, only: ty_cloud_optics +! use rrtmgp_lw_gas_optics, only: lw_gas_props + use interpolate_data, only: interp_type, lininterp_init, & + lininterp, extrap_method_bndry, & + lininterp_finish + use radiation_utils, only: get_mu_lambda_weights_ccpp + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_optical_props, only: ty_optical_props_1scl + + implicit none + public :: rrtmgp_lw_cloud_optics_run + + real(kind_phys), allocatable :: abs_lw_liq(:,:,:) + real(kind_phys), allocatable :: abs_lw_ice(:,:) + real(kind_phys), allocatable :: g_mu(:) + real(kind_phys), allocatable :: g_d_eff(:) + real(kind_phys), allocatable :: g_lambda(:,:) + real(kind_phys) :: tiny + integer :: nmu + integer :: nlambda + integer :: n_g_d + + +contains + + ! ###################################################################################### + ! SUBROUTINE rrtmgp_lw_cloud_optics_init() + ! ###################################################################################### +!> \section arg_table_rrtmgp_lw_cloud_optics_init Argument Table +!! \htmlinclude rrtmgp_lw_cloud_optics_init.html +!! + subroutine rrtmgp_lw_cloud_optics_init(nmu_in, nlambda_in, n_g_d_in, & + abs_lw_liq_in, abs_lw_ice_in, nlwbands, g_mu_in, g_lambda_in, & + g_d_eff_in, tiny_in, errmsg, errflg) + ! Inputs + integer, intent(in) :: nmu_in + integer, intent(in) :: nlambda_in + integer, intent(in) :: n_g_d_in + integer, intent(in) :: nlwbands + real(kind_phys), dimension(:,:,:), intent(in) :: abs_lw_liq_in + real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice_in + real(kind_phys), dimension(:,:), intent(in) :: g_lambda_in + real(kind_phys), dimension(:), intent(in) :: g_mu_in + real(kind_phys), dimension(:), intent(in) :: g_d_eff_in + real(kind_phys), intent(in) :: tiny_in + + ! Outputs + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + character(len=256) :: alloc_errmsg + character(len=*), parameter :: sub = 'rrtmgp_lw_cloud_optics_init' + + ! Set error variables + errmsg = '' + errflg = 0 + + ! Set module-level variables + nmu = nmu_in + nlambda = nlambda_in + n_g_d = n_g_d_in + tiny = tiny_in + ! Allocate module-level-variables + allocate(abs_lw_liq(nmu,nlambda,nlwbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR allocating abs_lw_liq, message: ', alloc_errmsg + return + end if + allocate(abs_lw_ice(n_g_d,nlwbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR allocating abs_lw_ice, message: ', alloc_errmsg + return + end if + allocate(g_mu(nmu), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR allocating g_mu, message: ', alloc_errmsg + return + end if + allocate(g_lambda(nmu,nlambda), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR allocating g_lambda, message: ', alloc_errmsg + return + end if + allocate(g_d_eff(n_g_d), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR allocating g_d_eff, message: ', alloc_errmsg + return + end if + + abs_lw_liq = abs_lw_liq_in + abs_lw_ice = abs_lw_ice_in + g_mu = g_mu_in + g_lambda = g_lambda_in + g_d_eff = g_d_eff_in + + end subroutine rrtmgp_lw_cloud_optics_init + + ! ###################################################################################### + ! SUBROUTINE rrtmgp_lw_cloud_optics_run() + ! ###################################################################################### +!> \section arg_table_rrtmgp_lw_cloud_optics_run Argument Table +!! \htmlinclude rrtmgp_lw_cloud_optics_run.html +!! + subroutine rrtmgp_lw_cloud_optics_run(ncol, nlay, nlaycam, cld, cldfsnow, cldfgrau, & + cldfprime, graupel_in_rad, kdist_lw, cloud_lw, lamc, pgam, iclwpth, iciwpth, & + dei, icswpth, des, icgrauwpth, degrau, nlwbands, do_snow, & + do_graupel, cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, pver, ktopcam, & + grau_lw_abs_cloudsim, idx_lw_cloudsim, tauc, cldf, errmsg, errflg) + ! 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 + + ! Inputs + integer, intent(in) :: ncol + integer, intent(in) :: nlay + integer, intent(in) :: nlaycam + integer, intent(in) :: nlwbands + integer, intent(in) :: pver + integer, intent(in) :: ktopcam + integer, intent(in) :: idx_lw_cloudsim + real(kind_phys), dimension(:,:), intent(in) :: cld + real(kind_phys), dimension(:,:), intent(in) :: cldfsnow + real(kind_phys), dimension(:,:), intent(in) :: cldfgrau + real(kind_phys), dimension(:,:), intent(in) :: cldfprime + real(kind_phys), dimension(:,:), intent(in) :: lamc + real(kind_phys), dimension(:,:), intent(in) :: pgam + real(kind_phys), dimension(:,:), intent(in) :: iclwpth + real(kind_phys), dimension(:,:), intent(in) :: iciwpth + real(kind_phys), dimension(:,:), intent(in) :: icswpth + real(kind_phys), dimension(:,:), intent(in) :: icgrauwpth + real(kind_phys), dimension(:,:), intent(in) :: dei + real(kind_phys), dimension(:,:), intent(in) :: des + real(kind_phys), dimension(:,:), intent(in) :: degrau + logical, intent(in) :: graupel_in_rad + logical, intent(in) :: do_snow + logical, intent(in) :: do_graupel + class(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw + + ! Outputs + type(ty_optical_props_1scl), intent(out) :: cloud_lw + real(kind_phys), dimension(:,:), intent(out) :: cld_lw_abs_cloudsim + real(kind_phys), dimension(:,:), intent(out) :: snow_lw_abs_cloudsim + real(kind_phys), dimension(:,:), intent(out) :: grau_lw_abs_cloudsim + real(kind_phys), dimension(:,:), intent(out) :: cldf + real(kind_phys), dimension(:,:,:), intent(out) :: tauc + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: idx, kdx + + ! cloud radiative parameters are "in cloud" not "in cell" + real(kind_phys) :: liq_lw_abs(nlwbands, ncol, pver) ! liquid absorption optics depth (LW) + real(kind_phys) :: ice_lw_abs(nlwbands, ncol, pver) ! ice absorption optics depth (LW) + real(kind_phys) :: cld_lw_abs(nlwbands, ncol, pver) ! cloud absorption optics depth (LW) + real(kind_phys) :: snow_lw_abs(nlwbands, ncol, pver) ! snow absorption optics depth (LW) + real(kind_phys) :: grau_lw_abs(nlwbands, ncol, pver) ! graupel absorption optics depth (LW) + real(kind_phys) :: c_cld_lw_abs(nlwbands, ncol, pver) ! combined cloud absorption optics depth (LW) + + character(len=*), parameter :: sub = 'rrtmgp_set_cloud_lw' + !-------------------------------------------------------------------------------- + + ! Combine the cloud optical properties. + + ! gammadist liquid optics + call liquid_cloud_get_rad_props_lw(ncol, pver, nmu, nlambda, nlwbands, lamc, pgam, g_mu, g_lambda, iclwpth, & + abs_lw_liq, liq_lw_abs, errmsg, errflg) + if (errflg /= 0) then + return + end if + ! Mitchell ice optics + call ice_cloud_get_rad_props_lw(ncol, pver, nlwbands, iciwpth, dei, n_g_d, g_d_eff, abs_lw_ice, ice_lw_abs, & + errmsg, errflg) + if (errflg /= 0) then + return + end if + + cld_lw_abs(:,:,:) = liq_lw_abs(:,:,:) + ice_lw_abs(:,:,:) + + if (do_snow) then + ! add in snow + call snow_cloud_get_rad_props_lw(ncol, pver, nlwbands, icswpth, des, n_g_d, g_d_eff, abs_lw_ice, & + snow_lw_abs, errmsg, errflg) + if (errflg /= 0) then + return + end if + do idx = 1, ncol + do kdx = 1, pver + if (cldfprime(idx,kdx) > 0._kind_phys) then + c_cld_lw_abs(:,idx,kdx) = ( cldfsnow(idx,kdx)*snow_lw_abs(:,idx,kdx) & + + cld(idx,kdx)*cld_lw_abs(:,idx,kdx) )/cldfprime(idx,kdx) + else + c_cld_lw_abs(:,idx,kdx) = 0._kind_phys + end if + end do + end do + else + c_cld_lw_abs(:,:,:) = cld_lw_abs(:,:,:) + end if + + ! add in graupel + if (do_graupel .and. graupel_in_rad) then + call grau_cloud_get_rad_props_lw(ncol, pver, nlwbands, icgrauwpth, degrau, n_g_d, g_d_eff, abs_lw_ice, & + grau_lw_abs, errmsg, errflg) + if (errflg /= 0) then + return + end if + do idx = 1, ncol + do kdx = 1, pver + if (cldfprime(idx,kdx) > 0._kind_phys) then + c_cld_lw_abs(:,idx,kdx) = ( cldfgrau(idx,kdx)*grau_lw_abs(:,idx,kdx) & + + cld(idx,kdx)*c_cld_lw_abs(:,idx,kdx) )/cldfprime(idx,kdx) + else + c_cld_lw_abs(:,idx,kdx) = 0._kind_phys + 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,:,:) + + ! Extract just the layers of CAM where RRTMGP does calculations + + ! Subset "chunk" data so just the number of CAM layers in the + ! radiation calculation are used by MCICA to produce subcolumns + cldf = cldfprime(:, ktopcam:) + tauc = c_cld_lw_abs(:, :, ktopcam:) + + ! Enforce tauc >= 0. + tauc = merge(tauc, 0.0_kind_phys, tauc > 0.0_kind_phys) + + errmsg =cloud_lw%alloc_1scl(ncol, nlay, kdist_lw) + if (len_trim(errmsg) > 0) then + errflg = 1 + return + end if + + end subroutine rrtmgp_lw_cloud_optics_run + +!============================================================================== + + subroutine liquid_cloud_get_rad_props_lw(ncol, pver, nmu, nlambda, nlwbands, lamc, pgam, & + g_mu, g_lambda, iclwpth, abs_lw_liq, abs_od, errmsg, errflg) + ! Inputs + integer, intent(in) :: ncol + integer, intent(in) :: pver + integer, intent(in) :: nmu + integer, intent(in) :: nlambda + integer, intent(in) :: nlwbands + real(kind_phys), dimension(:,:), intent(in) :: lamc + real(kind_phys), dimension(:,:), intent(in) :: pgam + real(kind_phys), dimension(:,:,:), intent(in) :: abs_lw_liq + real(kind_phys), dimension(:), intent(in) :: g_mu + real(kind_phys), dimension(:,:), intent(in) :: g_lambda + real(kind_phys), dimension(:,:), intent(in) :: iclwpth + ! Outputs + real(kind_phys), dimension(:,:,:), intent(out) :: abs_od + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer lwband, idx, kdx + + ! Set error variables + errflg = 0 + errmsg = '' + + abs_od = 0._kind_phys + + do kdx = 1,pver + do idx = 1,ncol + if(lamc(idx,kdx) > 0._kind_phys) then ! This seems to be the clue for no cloud from microphysics formulation + call gam_liquid_lw(nlwbands, nmu, nlambda, iclwpth(idx,kdx), lamc(idx,kdx), pgam(idx,kdx), abs_lw_liq, & + g_mu, g_lambda, abs_od(1:nlwbands,idx,kdx), errmsg, errflg) + else + abs_od(1:nlwbands,idx,kdx) = 0._kind_phys + endif + enddo + enddo + + end subroutine liquid_cloud_get_rad_props_lw + +!============================================================================== + + subroutine gam_liquid_lw(nlwbands, nmu, nlambda, clwptn, lamc, pgam, abs_lw_liq, g_mu, g_lambda, abs_od, errmsg, errflg) + ! Inputs + integer, intent(in) :: nlwbands + integer, intent(in) :: nmu + integer, intent(in) :: nlambda + real(kind_phys), intent(in) :: clwptn ! cloud water liquid path new (in cloud) (in g/m^2)? + real(kind_phys), intent(in) :: lamc ! prognosed value of lambda for cloud + real(kind_phys), intent(in) :: pgam ! prognosed value of mu for cloud + real(kind_phys), dimension(:,:,:), intent(in) :: abs_lw_liq + real(kind_phys), dimension(:), intent(in) :: g_mu + real(kind_phys), dimension(:,:) , intent(in) :: g_lambda + ! Outputs + real(kind_phys), dimension(:), intent(out) :: abs_od + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + + integer :: lwband ! sw band index + + type(interp_type) :: mu_wgts + type(interp_type) :: lambda_wgts + + if (clwptn < tiny) then + abs_od = 0._kind_phys + return + endif + + call get_mu_lambda_weights_ccpp(nmu, nlambda, g_mu, g_lambda, lamc, pgam, mu_wgts, lambda_wgts, errmsg, errflg) + if (errflg /= 0) then + return + end if + + 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 ice_cloud_get_rad_props_lw(ncol, pver, nlwbands, iciwpth, dei, & + n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) + integer, intent(in) :: ncol + integer, intent(in) :: pver + integer, intent(in) :: n_g_d + integer, intent(in) :: nlwbands + real(kind_phys), dimension(:), intent(in) :: g_d_eff + real(kind_phys), dimension(:,:), intent(in) :: iciwpth + real(kind_phys), dimension(:,:), intent(in) :: dei + real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice + real(kind_phys), dimension(:,:,:), intent(out) :: abs_od + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Set error variables + errflg = 0 + errmsg = '' + + call interpolate_ice_optics_lw(ncol, pver, nlwbands, iciwpth, dei, & + n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) + + end subroutine ice_cloud_get_rad_props_lw + +!============================================================================== + + subroutine snow_cloud_get_rad_props_lw(ncol, pver, nlwbands, icswpth, des, & + n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) + integer, intent(in) :: ncol + integer, intent(in) :: pver + integer, intent(in) :: n_g_d + integer, intent(in) :: nlwbands + real(kind_phys), dimension(:), intent(in) :: g_d_eff + real(kind_phys), dimension(:,:), intent(in) :: icswpth + real(kind_phys), dimension(:,:), intent(in) :: des + real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice + real(kind_phys), dimension(:,:,:), intent(out) :: abs_od + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errflg = 0 + errmsg = '' + + call interpolate_ice_optics_lw(ncol, pver, nlwbands, icswpth, des, & + n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) + + end subroutine snow_cloud_get_rad_props_lw + +!============================================================================== + + subroutine grau_cloud_get_rad_props_lw(ncol, pver, nlwbands, icgrauwpth, degrau, & + n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) + integer, intent(in) :: ncol + integer, intent(in) :: pver + integer, intent(in) :: n_g_d + integer, intent(in) :: nlwbands + real(kind_phys), dimension(:), intent(in) :: g_d_eff + real(kind_phys), dimension(:,:), intent(in) :: icgrauwpth + real(kind_phys), dimension(:,:), intent(in) :: degrau + real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice + real(kind_phys), dimension(:,:,:), intent(out) :: abs_od + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! This does the same thing as ice_cloud_get_rad_props_lw, except with a + ! different water path and effective diameter. + call interpolate_ice_optics_lw(ncol, pver, nlwbands, icgrauwpth, degrau, n_g_d, & + g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) + + end subroutine grau_cloud_get_rad_props_lw + +!============================================================================== + + subroutine interpolate_ice_optics_lw(ncol, pver, nlwbands, iciwpth, dei, & + n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) + + integer, intent(in) :: ncol + integer, intent(in) :: n_g_d + integer, intent(in) :: pver + integer, intent(in) :: nlwbands + real(kind_phys), dimension(:), intent(in) :: g_d_eff + real(kind_phys), dimension(:,:), intent(in) :: iciwpth + real(kind_phys), dimension(:,:), intent(in) :: dei + real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice + real(kind_phys), dimension(:,:,:), intent(out) :: abs_od + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + type(interp_type) :: dei_wgts + + integer :: idx, kdx, lwband + real(kind_phys) :: absor(nlwbands) + + ! Set error variables + errflg = 0 + errmsg = '' + + do kdx = 1,pver + do idx = 1,ncol + ! if ice water path is too small, OD := 0 + if( iciwpth(idx,kdx) < tiny .or. dei(idx,kdx) == 0._kind_phys) then + abs_od (:,idx,kdx) = 0._kind_phys + else + ! for each cell interpolate to find weights in g_d_eff grid. + call lininterp_init(g_d_eff, n_g_d, dei(idx:idx,kdx), 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(:,idx,kdx) = iciwpth(idx,kdx) * absor + where(abs_od(:,idx,kdx) > 50.0_kind_phys) abs_od(:,idx,kdx) = 50.0_kind_phys + call lininterp_finish(dei_wgts) + endif + enddo + enddo + + end subroutine interpolate_ice_optics_lw + +!============================================================================== + +end module rrtmgp_lw_cloud_optics diff --git a/src/physics/rrtmgp/rrtmgp_lw_initialize_fluxes.F90 b/src/physics/rrtmgp/rrtmgp_lw_initialize_fluxes.F90 new file mode 100644 index 0000000000..c3a367526f --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_lw_initialize_fluxes.F90 @@ -0,0 +1,180 @@ +module rrtmgp_lw_initialize_fluxes + + public :: rrtmgp_lw_initialize_fluxes_run + +contains +!> \section arg_table_rrtmgp_lw_initialize_fluxes_run Argument Table +!! \htmlinclude rrtmgp_lw_initialize_fluxes_run.html +!! + subroutine rrtmgp_lw_initialize_fluxes_run(rrtmgp_phys_blksz, nlay, nlwbands, spectralflux, flux_allsky, flux_clrsky, & + errmsg, errflg) + use mo_fluxes, only: ty_fluxes_broadband + use mo_fluxes_byband, only: ty_fluxes_byband + ! Inputs + integer, intent(in) :: rrtmgp_phys_blksz + integer, intent(in) :: nlay + integer, intent(in) :: nlwbands + logical, intent(in) :: spectralflux + ! Outputs + class(ty_fluxes_broadband), intent(out) :: flux_clrsky + class(ty_fluxes_broadband), intent(out) :: flux_allsky + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + character(len=256) :: alloc_errmsg + integer :: play + + play = nlay + 1 + + ! Set error variables + errmsg = '' + errflg = 0 + + ! Clearsky fluxes + allocate(flux_clrsky%flux_up(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%flux_up". Message: ', & + alloc_errmsg + return + end if + + allocate(flux_clrsky%flux_dn(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%flux_dn". Message: ', & + alloc_errmsg + return + end if + + allocate(flux_clrsky%flux_net(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%flux_net". Message: ', & + alloc_errmsg + return + end if + + select type (flux_clrsky) + type is (ty_fluxes_byband) + ! Only allocate when spectralflux is true. + if (spectralflux) then + allocate(flux_clrsky%bnd_flux_up(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%bnd_flux_up". Message: ', & + alloc_errmsg + return + end if + + allocate(flux_clrsky%bnd_flux_dn(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%bnd_flux_dn". Message: ', & + alloc_errmsg + return + end if + + allocate(flux_clrsky%bnd_flux_net(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%bnd_flux_net". Message: ', & + alloc_errmsg + return + end if + end if + end select + + ! Initialize + call reset_fluxes(flux_clrsky) + + ! Allsky fluxes + allocate(flux_allsky%flux_up(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%flux_up". Message: ', & + alloc_errmsg + return + end if + + allocate(flux_allsky%flux_dn(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%flux_dn". Message: ', & + alloc_errmsg + return + end if + + allocate(flux_allsky%flux_net(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%flux_net". Message: ', & + alloc_errmsg + return + end if +! if (do_direct_local) then +! allocate(flux_allsky%flux_dn_dir(rrtmgp_phys_blksz, play), stat=errflg) +! call handle_allocate_error(errflg, sub, 'flux_allsky%flux_dn_dir') +! end if + + select type (flux_allsky) + type is (ty_fluxes_byband) + ! Fluxes by band always needed for SW. Only allocate for LW + ! when spectralflux is true. + if (spectralflux) then + allocate(flux_allsky%bnd_flux_up(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%bnd_flux_up". Message: ', & + alloc_errmsg + return + end if + + allocate(flux_allsky%bnd_flux_dn(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%bnd_flux_dn". Message: ', & + alloc_errmsg + return + end if + + allocate(flux_allsky%bnd_flux_net(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%bnd_flux_net". Message: ', & + alloc_errmsg + return + end if + ! if (do_direct) then + ! allocate(flux_allsky%bnd_flux_dn_dir(rrtmgp_phys_blksz, play, nlwbands), stat=errflg) + ! call handle_allocate_error(errflg, sub, 'flux_allsky%bnd_flux_dn_dir') + ! allocate(flux_allsky%bnd_flux_dn_dir(rrtmgp_phys_blksz, play, nbands), stat=errflg) + ! call handle_allocate_error(errflg, sub, 'flux_allsky%bnd_flux_dn_dir') + ! end if + end if + end select + + ! Initialize + call reset_fluxes(flux_allsky) + + end subroutine rrtmgp_lw_initialize_fluxes_run + +!========================================================================================= + + subroutine reset_fluxes(fluxes) + use mo_fluxes, only: ty_fluxes_broadband + use mo_fluxes_byband, only: ty_fluxes_byband + use ccpp_kinds, only: kind_phys + + ! Reset flux arrays to zero. + + class(ty_fluxes_broadband), intent(inout) :: fluxes + !---------------------------------------------------------------------------- + + ! Reset broadband fluxes + fluxes%flux_up(:,:) = 0._kind_phys + fluxes%flux_dn(:,:) = 0._kind_phys + fluxes%flux_net(:,:) = 0._kind_phys + if (associated(fluxes%flux_dn_dir)) fluxes%flux_dn_dir(:,:) = 0._kind_phys + + select type (fluxes) + type is (ty_fluxes_byband) + ! Reset band-by-band fluxes + if (associated(fluxes%bnd_flux_up)) fluxes%bnd_flux_up(:,:,:) = 0._kind_phys + if (associated(fluxes%bnd_flux_dn)) fluxes%bnd_flux_dn(:,:,:) = 0._kind_phys + if (associated(fluxes%bnd_flux_net)) fluxes%bnd_flux_net(:,:,:) = 0._kind_phys + if (associated(fluxes%bnd_flux_dn_dir)) fluxes%bnd_flux_dn_dir(:,:,:) = 0._kind_phys + end select + + end subroutine reset_fluxes + +end module rrtmgp_lw_initialize_fluxes diff --git a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 new file mode 100644 index 0000000000..fe2d3804f5 --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 @@ -0,0 +1,189 @@ +module rrtmgp_lw_mcica_subcol_gen +! PEVERWHEE - dependencies = shr_RandNum_mod + +!---------------------------------------------------------------------------------------- +! +! Purpose: Create McICA stochastic arrays for lw 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). | +! | 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/) | +! | | +! -------------------------------------------------------------------------- +! This code is a refactored version of code originally in the files +! rrtmgp_lw_mcica_subcol_gen.F90 and mcica_subcol_gen_sw.F90 +! +! Uses the KISS random number generator. +! +! Overlap assumption: maximum-random. +! +!---------------------------------------------------------------------------------------- + +use machine, only: kind_phys +use shr_RandNum_mod, only: ShrKissRandGen +use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp +use mo_optical_props, only: ty_optical_props_1scl + +implicit none +private +save + +public :: rrtmgp_lw_mcica_subcol_gen_run + +!======================================================================================== +contains +!======================================================================================== + +!> +!> \section arg_table_rrtmgp_lw_mcica_subcol_gen_run Argument Table +!! \htmlinclude rrtmgp_lw_mcica_subcol_gen_run.html +subroutine rrtmgp_lw_mcica_subcol_gen_run( & + ktoprad, kdist, nbnd, ngpt, ncol, pver, nver, & + changeseed, pmid, cldfrac, tauc, cloud_lw, & + errmsg, errflg ) + + ! 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_rrtmgp), intent(in) :: kdist ! spectral information + integer, intent(in) :: ktoprad + 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) :: pver ! total number of layers + 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(kind_phys), dimension(:,:), intent(in) :: pmid ! layer pressures (Pa) + real(kind_phys), dimension(:,:), intent(in) :: cldfrac ! layer cloud fraction + real(kind_phys), dimension(:,:,:), intent(in) :: tauc ! cloud optical depth + type(ty_optical_props_1scl), intent(inout) :: cloud_lw + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + + integer :: idx, isubcol, kdx, ndx + + real(kind_phys), parameter :: cldmin = 1.0e-80_kind_phys ! min cloud fraction + real(kind_phys) :: cldf(ncol,pver) ! cloud fraction clipped to cldmin + + type(ShrKissRandGen) :: kiss_gen ! KISS RNG object + integer :: kiss_seed(ncol,4) + real(kind_phys) :: rand_num_1d(ncol,1) ! random number (kissvec) + real(kind_phys) :: rand_num(ncol,nver) ! random number (kissvec) + + real(kind_phys) :: cdf(ngpt,ncol,nver) ! random numbers + logical :: iscloudy(ngpt,ncol,nver) ! flag that says whether a gridbox is cloudy + real(kind_phys) :: taucmcl(ngpt,ncol,nver) + !------------------------------------------------------------------------------------------ + + ! Set error variables + errflg = 0 + errmsg = '' + + ! clip cloud fraction + cldf(:,:) = cldfrac(:ncol,:) + where (cldf(:,:) < cldmin) + cldf(:,:) = 0._kind_phys + end where + + ! Create a seed that depends on the state of the columns. + ! Use pmid from bottom four layers. + do idx = 1, ncol + kiss_seed(idx,1) = (pmid(idx,pver) - int(pmid(idx,pver))) * 1000000000 + kiss_seed(idx,2) = (pmid(idx,pver-1) - int(pmid(idx,pver-1))) * 1000000000 + kiss_seed(idx,3) = (pmid(idx,pver-2) - int(pmid(idx,pver-2))) * 1000000000 + kiss_seed(idx,4) = (pmid(idx,pver-3) - int(pmid(idx,pver-3))) * 1000000000 + end do + + ! create the RNG object + kiss_gen = ShrKissRandGen(kiss_seed) + + ! Advance randum number generator by changeseed values + do idx = 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 kdx = 2, nver + do idx = 1, ncol + do isubcol = 1, ngpt + if (cdf(isubcol,idx,kdx-1) > 1._kind_phys - cldf(idx,kdx-1) ) then + cdf(isubcol,idx,kdx) = cdf(isubcol,idx,kdx-1) + else + cdf(isubcol,idx,kdx) = cdf(isubcol,idx,kdx) * (1._kind_phys - cldf(idx,kdx-1)) + end if + end do + end do + end do + + do kdx = 1, nver + iscloudy(:,:,kdx) = (cdf(:,:,kdx) >= 1._kind_phys - spread(cldf(:,kdx), 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 kdx = 1,nver + do idx = 1,ncol + do isubcol = 1,ngpt + if (iscloudy(isubcol,idx,kdx) .and. (cldf(idx,kdx) > 0._kind_phys) ) then + ndx = kdist%convert_gpt2band(isubcol) + taucmcl(isubcol,idx,kdx) = tauc(ndx,idx,kdx) + else + taucmcl(isubcol,idx,kdx) = 0._kind_phys + end if + end do + end do + end do + + call kiss_gen%finalize() + + ! If there is an extra layer in the radiation then this initialization + ! will provide zero optical depths there + cloud_lw%tau = 0.0_kind_phys + + ! Set the properties on g-points + do idx = 1, ngpt + cloud_lw%tau(:,ktoprad:,idx) = taucmcl(idx,:,:) + end do + + ! validate checks that: tau > 0 + errmsg = cloud_lw%validate() + if (len_trim(errmsg) > 0) then + errflg = 1 + return + end if + +end subroutine rrtmgp_lw_mcica_subcol_gen_run + + +end module rrtmgp_lw_mcica_subcol_gen + diff --git a/src/physics/rrtmgp/rrtmgp_pre.F90 b/src/physics/rrtmgp/rrtmgp_pre.F90 index 093115a9a8..ff213d6684 100644 --- a/src/physics/rrtmgp/rrtmgp_pre.F90 +++ b/src/physics/rrtmgp/rrtmgp_pre.F90 @@ -1,17 +1,21 @@ module rrtmgp_pre use ccpp_kinds, only: kind_phys + use cam_logfile, only: iulog public :: rrtmgp_pre_run + public :: radiation_do_ccpp CONTAINS !> \section arg_table_rrtmgp_pre_run Argument Table !! \htmlinclude rrtmgp_pre_run.html !! - subroutine rrtmgp_pre_run(coszrs, nstep, iradsw, iradlw, irad_always, & - ncol, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) + subroutine rrtmgp_pre_run(coszrs, nstep, dtime, iradsw, iradlw, irad_always, ncol, & + nextsw_cday, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use time_manager, only: get_curr_calday real(kind_phys), dimension(:), intent(in) :: coszrs + integer, intent(in) :: dtime integer, intent(in) :: nstep integer, intent(in) :: iradsw integer, intent(in) :: iradlw @@ -19,6 +23,7 @@ subroutine rrtmgp_pre_run(coszrs, nstep, iradsw, iradlw, irad_always, & integer, intent(in) :: ncol integer, intent(out) :: nday integer, intent(out) :: nnite + real(kind_phys), intent(out) :: nextsw_cday integer, dimension(:), intent(out) :: idxday integer, dimension(:), intent(out) :: idxnite logical, intent(out) :: dosw @@ -28,6 +33,10 @@ subroutine rrtmgp_pre_run(coszrs, nstep, iradsw, iradlw, irad_always, & ! Local variables integer :: idx + integer :: offset + integer :: nstep_next + logical :: dosw_next + real(kind_phys) :: caldayp1 ! Set error variables errflg = 0 @@ -47,13 +56,79 @@ subroutine rrtmgp_pre_run(coszrs, nstep, iradsw, iradlw, irad_always, & end do ! Determine if we're going to do longwave and/or shortwave this timestep - dosw = nstep == 0 .or. iradsw == 1 & - .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always + call radiation_do_ccpp('sw', nstep, iradsw, irad_always, dosw, errmsg, errflg) + if (errflg /= 0) then + return + end if + call radiation_do_ccpp('lw', nstep, iradlw, irad_always, dolw, errmsg, errflg) + if (errflg /= 0) then + return + end if - dolw = nstep == 0 .or. iradlw == 1 & - .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always + ! Get time of next radiation calculation - albedos will need to be + ! calculated by each surface model at this time + nextsw_cday = -1._kind_phys + dosw_next = .false. + offset = 0 + nstep_next = nstep + do while (.not. dosw_next) + nstep_next = nstep_next + 1 + offset = offset + dtime + call radiation_do_ccpp('sw', nstep_next, iradsw, irad_always, dosw_next, errmsg, errflg) + if (errflg /= 0) then + return + end if + if (dosw_next) then + nextsw_cday = get_curr_calday(offset=offset) + end if + end do + if(nextsw_cday == -1._kind_phys) then + errflg = 1 + errmsg = 'next calendar day with shortwave calculation not found' + return + end if + + ! determine if next radiation time-step not equal to next time-step + if (nstep >= 1) then + caldayp1 = get_curr_calday(offset=int(dtime)) + if (caldayp1 /= nextsw_cday) nextsw_cday = -1._kind_phys + end if end subroutine rrtmgp_pre_run +!================================================================================================ + +subroutine radiation_do_ccpp(op, nstep, irad, irad_always, radiation_do, errmsg, errflg) + + ! Return true if the specified operation is done this timestep. + + character(len=*), intent(in) :: op ! name of operation + integer, intent(in) :: nstep + integer, intent(in) :: irad + integer, intent(in) :: irad_always + integer, intent(out) :: errflg + character(len=*), intent(out) :: errmsg + logical, intent(out) :: radiation_do ! return value + + !----------------------------------------------------------------------- + + ! Set error variables + errflg = 0 + errmsg = '' + + select case (op) + case ('sw') ! do a shortwave heating calc this timestep? + radiation_do = nstep == 0 .or. irad == 1 & + .or. (mod(nstep-1,irad) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + case ('lw') ! do a longwave heating calc this timestep? + radiation_do = nstep == 0 .or. irad == 1 & + .or. (mod(nstep-1,irad) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + case default + errflg = 1 + errmsg = 'radiation_do_ccpp: unknown operation:'//op + end select + +end subroutine radiation_do_ccpp + end module rrtmgp_pre From 9e9533975e6e69193495fb2460ee9a6d43272638 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Tue, 25 Mar 2025 16:24:21 -0600 Subject: [PATCH 05/17] rrtmgp lw works! --- src/physics/cam/radheat.F90 | 18 +- src/physics/rrtmgp/calculate_net_heating.F90 | 69 ++++++ src/physics/rrtmgp/radiation.F90 | 156 ++++++------ src/physics/rrtmgp/radiation_utils.F90 | 1 + .../rrtmgp_dry_static_energy_tendency.F90 | 63 +++++ src/physics/rrtmgp/rrtmgp_inputs.F90 | 1 - src/physics/rrtmgp/rrtmgp_inputs_cam.F90 | 162 +------------ src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 | 5 +- src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 | 81 +++++++ .../rrtmgp/rrtmgp_lw_gas_optics_data.F90 | 98 ++++++++ .../rrtmgp/rrtmgp_lw_gas_optics_pre.F90 | 191 +++++++++++++++ src/physics/rrtmgp/rrtmgp_lw_main.F90 | 226 ++++++++++++++++++ src/physics/rrtmgp/rrtmgp_post.F90 | 101 ++++++++ src/physics/rrtmgp/rrtmgp_pre.F90 | 186 ++++++++++++-- 14 files changed, 1092 insertions(+), 266 deletions(-) create mode 100644 src/physics/rrtmgp/calculate_net_heating.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_lw_main.F90 create mode 100644 src/physics/rrtmgp/rrtmgp_post.F90 diff --git a/src/physics/cam/radheat.F90 b/src/physics/cam/radheat.F90 index 37f8127931..5fe856966c 100644 --- a/src/physics/cam/radheat.F90 +++ b/src/physics/cam/radheat.F90 @@ -82,6 +82,7 @@ subroutine radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & #if ( defined OFFLINE_DYN ) use metdata, only: met_rlx, met_srf_feedback #endif + use calculate_net_heating, only: calculate_net_heating_run !----------------------------------------------------------------------- ! Compute net radiative heating from qrs and qrl, and the associated net ! boundary flux. @@ -91,7 +92,7 @@ subroutine radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & type(physics_state), intent(in) :: state ! Physics state variables type(physics_buffer_desc), pointer :: pbuf(:) - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencie + type(physics_ptend), intent(out) :: ptend ! individual parameterization tendencies real(r8), intent(in) :: qrl(pcols,pver) ! longwave heating real(r8), intent(in) :: qrs(pcols,pver) ! shortwave heating real(r8), intent(in) :: fsns(pcols) ! Surface solar absorbed flux @@ -105,8 +106,14 @@ subroutine radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & ! Local variables integer :: i, k integer :: ncol + character(len=512) :: errmsg + integer :: errflg !----------------------------------------------------------------------- + ! Set error variables + errmsg = '' + errflg = 0 + ncol = state%ncol call physics_ptend_init(ptend,state%psetcols, 'radheat', ls=.true.) @@ -118,14 +125,13 @@ subroutine radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & ptend%s(:ncol,k) = (qrs(:ncol,k) + qrl(:ncol,k)) endif enddo + call calculate_net_heating_run(ncol, ptend%s, qrl, qrs, fsns, fsnt, flns, flnt, & + .true., net_flx, errmsg, errflg) #else - ptend%s(:ncol,:) = (qrs(:ncol,:) + qrl(:ncol,:)) + call calculate_net_heating_run(ncol, ptend%s, qrl, qrs, fsns, fsnt, flns, flnt, & + .false., net_flx, errmsg, errflg) #endif - do i = 1, ncol - net_flx(i) = fsnt(i) - fsns(i) - flnt(i) + flns(i) - end do - end subroutine radheat_tend !================================================================================================ diff --git a/src/physics/rrtmgp/calculate_net_heating.F90 b/src/physics/rrtmgp/calculate_net_heating.F90 new file mode 100644 index 0000000000..b445ac1d7e --- /dev/null +++ b/src/physics/rrtmgp/calculate_net_heating.F90 @@ -0,0 +1,69 @@ +module calculate_net_heating +! PEVERWHEE - this should go in schemes/rrtmgp/utils +!----------------------------------------------------------------------- +! +! Purpose: Provide an interface to convert shortwave and longwave +! radiative heating terms into net heating. +! +! This module provides a hook to allow incorporating additional +! radiative terms (eUV heating and nonLTE longwave cooling). +! +! Original version: B.A. Boville +!----------------------------------------------------------------------- + +use ccpp_kinds, only: kind_phys + +implicit none +private +save + +! Public interfaces +public :: calculate_net_heating_run + +!=============================================================================== +contains +!=============================================================================== + +!> \section arg_table_calculate_net_heating_run Argument Table +!! \htmlinclude calculate_net_heating_run.html +!! +subroutine calculate_net_heating_run(ncol, rad_heat, qrl, qrs, fsns, fsnt, flns, flnt, & + is_offline_dyn, net_flx, errmsg, errflg) +!----------------------------------------------------------------------- +! Compute net radiative heating from qrs and qrl, and the associated net +! boundary flux. +!----------------------------------------------------------------------- + + ! Arguments + integer, intent(in) :: ncol ! horizontal dimension + real(kind_phys), intent(in) :: qrl(:,:) ! longwave heating + real(kind_phys), intent(in) :: qrs(:,:) ! shortwave heating + real(kind_phys), intent(in) :: fsns(:) ! Surface solar absorbed flux + real(kind_phys), intent(in) :: fsnt(:) ! Net column abs solar flux at model top + real(kind_phys), intent(in) :: flns(:) ! Srf longwave cooling (up-down) flux + real(kind_phys), intent(in) :: flnt(:) ! Net outgoing lw flux at model top + logical, intent(in) :: is_offline_dyn ! is offline dycore + real(kind_phys), intent(out) :: rad_heat(:,:) ! radiative heating + real(kind_phys), intent(out) :: net_flx(:) ! net boundary flux + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + + ! Local variables + integer :: idx + !----------------------------------------------------------------------- + ! Set error variables + errmsg = '' + errflg = 0 + if (.not. is_offline_dyn) then + rad_heat(:ncol,:) = (qrs(:ncol,:) + qrl(:ncol,:)) + end if + + do idx = 1, ncol + net_flx(idx) = fsnt(idx) - fsns(idx) - flnt(idx) + flns(idx) + end do + +end subroutine calculate_net_heating_run + +!================================================================================================ +end module calculate_net_heating diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index b1062872b5..149e4d65c8 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -816,8 +816,13 @@ subroutine radiation_tend( & use rrtmgp_lw_initialize_fluxes, only: rrtmgp_lw_initialize_fluxes_run use rrtmgp_lw_cloud_optics, only: rrtmgp_lw_cloud_optics_run use rrtmgp_lw_mcica_subcol_gen, only: rrtmgp_lw_mcica_subcol_gen_run + use rrtmgp_lw_gas_optics_pre, only: rrtmgp_lw_gas_optics_pre_run + use rrtmgp_lw_gas_optics, only: rrtmgp_lw_gas_optics_run + use rrtmgp_lw_main, only: rrtmgp_lw_main_run + use rrtmgp_dry_static_energy_tendency, only: rrtmgp_dry_static_energy_tendency_run + use rrtmgp_post, only: rrtmgp_post_run - use rrtmgp_inputs_cam, only: rrtmgp_set_gases_lw, & + use rrtmgp_inputs_cam, only: rrtmgp_get_gas_mmrs, & rrtmgp_set_aer_lw, rrtmgp_set_gases_sw, rrtmgp_set_cloud_sw, & rrtmgp_set_aer_sw @@ -850,7 +855,7 @@ subroutine radiation_tend( & ! if the argument is not present logical :: write_output - integer :: i, k, istat + integer :: i, k, gas_idx, istat integer :: lchnk, ncol logical :: dosw, dolw integer :: icall ! loop index for climate/diagnostic radiation calls @@ -910,6 +915,8 @@ subroutine radiation_tend( & real(r8), allocatable :: tauc(:,:,:) real(r8), allocatable :: cldf(:,:) + real(r8), allocatable :: gas_mmrs(:,:,:) + ! in-cloud optical depths for COSP real(r8) :: cld_tau_cloudsim(pcols,pver) ! liq + ice real(r8) :: snow_tau_cloudsim(pcols,pver) ! snow @@ -966,6 +973,10 @@ subroutine radiation_tend( & real(r8) :: fnl(pcols,pverp) ! net longwave flux real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux + ! Unused variables for rte_lw + real(r8) :: fluxlwup_jac(1,1) + real(r8) :: lw_ds(1,1) + ! for COSP real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau @@ -1011,7 +1022,8 @@ subroutine radiation_tend( & end if call rrtmgp_pre_run(coszrs, get_nstep(), get_step_size(), iradsw, iradlw, irad_always, & - ncol, nextsw_cday, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) + ncol, nextsw_cday, idxday, nday, idxnite, nnite, dosw, dolw, nlay, nlwbands, & + nswbands, spectralflux, fsw, fswc, flw, flwc, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if @@ -1045,15 +1057,6 @@ subroutine radiation_tend( & call pbuf_get_field(pbuf, ld_idx, ld) end if - ! 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 rrtmgp_lw_initialize_fluxes_run(ncol, nlay, nlwbands, spectralflux, flw, flwc, & - errmsg, errflg) - if (errflg /= 0) then - call endrun(sub//': '//errmsg) - end if - ! For CRM, make cloud equal to input observations: if (scm_crm_mode .and. have_cld) then do k = 1, pver @@ -1081,6 +1084,10 @@ subroutine radiation_tend( & coszrs_day(nday), alb_dir(nswbands,nday), alb_dif(nswbands,nday), & cldf(ncol,nlaycam), tauc(nlwbands,ncol,nlaycam), stat=istat) call handle_allocate_error(istat, sub, 't_sfc,..,alb_dif') + allocate(gas_mmrs(ncol, pver, nradgas), stat=istat, errmsg=errmsg) + if (errflg /= 0) then + call handle_allocate_error(istat, sub, 'gas_mmrs, message: '//errmsg) + end if ! Prepares state variables, daylit columns, albedos for RRTMGP ! Also calculates modified cloud fraction @@ -1185,11 +1192,6 @@ subroutine radiation_tend( & end if ! (active_calls(icall)) end do ! loop over diagnostic calcs (icall) - - else - ! 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) !=======================! @@ -1245,34 +1247,35 @@ 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) + ! Grab the gas mass mixing ratios from rad_constituents + call rrtmgp_get_gas_mmrs(icall, state, pbuf, nlay, gas_mmrs) + + ! Set gas volume mixing ratios for this call in gas_concs_lw + call rrtmgp_lw_gas_optics_pre_run(icall, gas_mmrs, state%pmid, state%pint, nlay, ncol, gaslist, idxday, & + pverp, ktoprad, ktopcam, dolw, nradgas, gas_concs_lw, errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if ! 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) - call stop_on_err(errmsg, sub, 'kdist_lw%gas_optics') + call rrtmgp_lw_gas_optics_run(dolw, 1, ncol, ncol, pmid_rad, pint_rad, t_rad, & + t_sfc, gas_concs_lw, atm_optics_lw, sources_lw, t_rad, .false., kdist_lw, errmsg, & + errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if ! 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) - 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) - 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) - 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) - call stop_on_err(errmsg, sub, 'all-sky rte_lw') + call rrtmgp_lw_main_run(dolw, dolw, .true., .false., .false., & + 0, ncol, 1, ncol, atm_optics_lw, & + cloud_lw, top_at_1, sources_lw, emis_sfc, kdist_lw, & + aer_lw, fluxlwup_jac, lw_ds, flwc, flw, errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if + ! Transform RRTMGP outputs to CAM outputs and compute heating rates. call set_lw_diags() @@ -1282,11 +1285,6 @@ subroutine radiation_tend( & end if ! (active_calls(icall)) end do ! loop over diagnostic calcs (icall) - - else - ! 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( & @@ -1341,16 +1339,15 @@ subroutine radiation_tend( & cosp_cnt(lchnk) = 0 end if end if ! docosp - - else - ! 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 + ! Calculate dry static energy if LW calc wasn't done; needed before calling radheat_run + call rrtmgp_dry_static_energy_tendency_run(ncol, state%pdel, (.not. dosw), (.not. dolw), & + qrs, qrl, errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if + ! Output for PORT: Parallel Offline Radiative Transport call rad_data_write(pbuf, state, cam_in, coszrs) @@ -1370,25 +1367,15 @@ subroutine radiation_tend( & call outfld('HR', ftem, pcols, lchnk) end if - ! The radiative heating rates are carried in the physics buffer across timesteps - ! as Q*dp (for energy conservation). - qrs(:ncol,:) = qrs(:ncol,:) * state%pdel(:ncol,:) - qrl(:ncol,:) = qrl(:ncol,:) * state%pdel(:ncol,:) - if (.not. present(rd_out)) then 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) - call free_fluxes(fswc) - - call sources_lw%finalize() - call free_optics_lw(cloud_lw) - call free_optics_lw(aer_lw) - call free_fluxes(flw) - call free_fluxes(flwc) + + call rrtmgp_post_run(ncol, qrs, qrl, state%pdel, atm_optics_sw, cloud_sw, aer_sw, & + fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if !------------------------------------------------------------------------------- contains @@ -1751,6 +1738,7 @@ end subroutine radiation_output_lw !=============================================================================== subroutine coefs_init(coefs_file, available_gases, kdist) + use rrtmgp_lw_gas_optics_data, only: rrtmgp_lw_gas_optics_data_init ! Read data from coefficients file. Initialize the kdist object. ! available_gases object provides the gas names that CAM provides. @@ -1758,7 +1746,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! arguments character(len=*), intent(in) :: coefs_file class(ty_gas_concs), intent(in) :: available_gases - class(ty_gas_optics_rrtmgp), intent(out) :: kdist + class(ty_gas_optics_rrtmgp), intent(inout) :: kdist ! local variables type(file_desc_t) :: fh ! pio file handle @@ -1823,6 +1811,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) fit_coeffs character(len=128) :: error_msg + character(len=512) :: errmsg character(len=*), parameter :: sub = 'coefs_init' !---------------------------------------------------------------------------- @@ -2230,22 +2219,19 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! 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, & - 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) + call rrtmgp_lw_gas_optics_data_init(kdist, 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, & + errmsg, ierr) + if (ierr /= 0) then + call endrun(sub//': ERROR message: '//errmsg) + end if else if (allocated(solar_src_quiet)) then error_msg = kdist%load( & available_gases, gas_names, key_species, & diff --git a/src/physics/rrtmgp/radiation_utils.F90 b/src/physics/rrtmgp/radiation_utils.F90 index f16ad130a3..3c9ec24afb 100644 --- a/src/physics/rrtmgp/radiation_utils.F90 +++ b/src/physics/rrtmgp/radiation_utils.F90 @@ -1,4 +1,5 @@ module radiation_utils + ! PEVERWHEE - this should go in schemes/rrtmgp/utils use ccpp_kinds, only: kind_phys use interpolate_data, only: interp_type, lininterp_init, lininterp, & extrap_method_bndry diff --git a/src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 b/src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 new file mode 100644 index 0000000000..e4caf6f285 --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 @@ -0,0 +1,63 @@ +module rrtmgp_dry_static_energy_tendency +!----------------------------------------------------------------------- +! +! Purpose: Provide an interface to convert shortwave and longwave +! radiative heating terms into net heating. +! +! This module provides a hook to allow incorporating additional +! radiative terms (eUV heating and nonLTE longwave cooling). +! +! Original version: B.A. Boville +!----------------------------------------------------------------------- + +use ccpp_kinds, only: kind_phys + +implicit none +private +save + +! Public interfaces +public :: rrtmgp_dry_static_energy_tendency_run + +!=============================================================================== +contains +!=============================================================================== + +!> \section arg_table_rrtmgp_dry_static_energy_tendency_run Argument Table +!! \htmlinclude rrtmgp_dry_static_energy_tendency_run.html +!! +subroutine rrtmgp_dry_static_energy_tendency_run(ncol, pdel, calc_sw_heat, calc_lw_heat, & + qrs, qrl, errmsg, errflg) +!----------------------------------------------------------------------- +! Compute net radiative heating from qrs and qrl, and the associated net +! boundary flux. +!----------------------------------------------------------------------- + + ! Arguments + integer, intent(in) :: ncol + real(kind_phys), dimension(:,:), intent(in) :: pdel + logical, intent(in) :: calc_sw_heat + logical, intent(in) :: calc_lw_heat + real(kind_phys), dimension(:,:), intent(inout) :: qrs ! shortwave heating + real(kind_phys), dimension(:,:), intent(inout) :: qrl ! longwave heating + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + + !----------------------------------------------------------------------- + ! Set error variables + errmsg = '' + errflg = 0 + + if (calc_sw_heat) then + qrs(:ncol,:) = qrs(:ncol,:) / pdel(:ncol,:) + end if + + if (calc_lw_heat) then + qrl(:ncol,:) = qrl(:ncol,:) / pdel(:ncol,:) + end if + +end subroutine rrtmgp_dry_static_energy_tendency_run + +!================================================================================================ +end module rrtmgp_dry_static_energy_tendency diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 58e6be5258..7589929fe9 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -6,7 +6,6 @@ module rrtmgp_inputs use mo_source_functions, only: ty_source_func_lw use string_utils, only: to_lower use radiation_utils, only: radiation_utils_init, get_sw_spectral_boundaries_ccpp - use cam_logfile, only: iulog implicit none private diff --git a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 index 219ceef0e6..1c1f0a9d67 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 @@ -35,7 +35,6 @@ module rrtmgp_inputs_cam 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 use error_messages, only: alloc_err use radiation_utils, only: get_sw_spectral_boundaries_ccpp @@ -46,9 +45,8 @@ module rrtmgp_inputs_cam public :: & rrtmgp_inputs_cam_init, & - rrtmgp_set_gases_lw, & + rrtmgp_get_gas_mmrs, & rrtmgp_set_gases_sw, & - rrtmgp_set_cloud_lw, & rrtmgp_set_cloud_sw, & rrtmgp_set_aer_lw, & rrtmgp_set_aer_sw @@ -264,32 +262,29 @@ end subroutine rad_gas_get_vmr !================================================================================================== -subroutine rrtmgp_set_gases_lw(icall, state, pbuf, nlay, gas_concs) +subroutine rrtmgp_get_gas_mmrs(icall, state, pbuf, nlay, gas_mmrs) - ! 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 - ! whether the gas already has memory allocated, and if it does that memory is deallocated - ! and new memory is allocated. + ! Retrieve mass mixing ratios for radiatively active gases from rad_constituents ! arguments integer, intent(in) :: icall ! index of climate/diagnostic radiation call 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 + real(r8), intent(out) :: gas_mmrs(:,:,:) ! local variables integer :: i, ncol - character(len=*), parameter :: sub = 'rrtmgp_set_gases_lw' + real(r8), pointer :: gas_mmr(:,:) + character(len=*), parameter :: sub = 'rrtmgp_get_gas_mmrs' !-------------------------------------------------------------------------------- ncol = state%ncol do i = 1, nradgas - call rad_gas_get_vmr(icall, gaslist(i), state, pbuf, nlay, ncol, gas_concs) + call rad_cnst_get_gas(icall, gaslist(i), state, pbuf, gas_mmr) + gas_mmrs(:,:,i) = gas_mmr end do -end subroutine rrtmgp_set_gases_lw +end subroutine rrtmgp_get_gas_mmrs !================================================================================================== @@ -323,145 +318,6 @@ end subroutine rrtmgp_set_gases_sw !================================================================================================== -subroutine rrtmgp_set_cloud_lw( & - state, pbuf, ncol, nlay, nlaycam, nlwgpts, & - cld, cldfsnow, cldfgrau, cldfprime, graupel_in_rad, tauc, cldf, & - 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 - 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 - integer, intent(in) :: nlwgpts - 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 - real(r8), intent(in) :: tauc(:,:,:) - real(r8), intent(in) :: cldf(:,:) - - 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(inout) :: cloud_lw - - ! Diagnostic outputs - 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) - - ! Local variables - - 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) - 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) :: cldf(ncol,nlaycam) -! real(r8) :: tauc(nlwbands,ncol,nlaycam) - real(r8) :: taucmcl(nlwgpts,ncol,nlay) - - character(len=128) :: errmsg - character(len=*), parameter :: sub = 'rrtmgp_set_cloud_lw' - !-------------------------------------------------------------------------------- - - ! Combine the cloud optical properties. These calculations are done on CAM "chunks". -#if 0 - ! 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,:,:) - - ! Extract just the layers of CAM where RRTMGP does calculations. - - ! 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:) - - ! Enforce tauc >= 0. - tauc = merge(tauc, 0.0_r8, tauc > 0.0_r8) -#endif - - ! 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 ) - -! 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 - - ! Set the properties on g-points. - do i = 1, nlwgpts - cloud_lw%tau(:,ktoprad:,i) = taucmcl(i,:,:) - 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 - -end subroutine rrtmgp_set_cloud_lw - -!================================================================================================== - subroutine rrtmgp_set_cloud_sw( & state, pbuf, nlay, nday, idxday, nswgpts, & nnite, idxnite, pmid, cld, cldfsnow, & diff --git a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 index 663d1bca6a..c1cfda7a5b 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 @@ -9,9 +9,6 @@ !! cloud types visible to RRTMGP. module rrtmgp_lw_cloud_optics use machine, only: kind_phys - use mo_rte_kind, only: wl -! use mo_cloud_optics, only: ty_cloud_optics -! use rrtmgp_lw_gas_optics, only: lw_gas_props use interpolate_data, only: interp_type, lininterp_init, & lininterp, extrap_method_bndry, & lininterp_finish @@ -170,7 +167,7 @@ subroutine rrtmgp_lw_cloud_optics_run(ncol, nlay, nlaycam, cld, cldfsnow, cldfgr real(kind_phys) :: grau_lw_abs(nlwbands, ncol, pver) ! graupel absorption optics depth (LW) real(kind_phys) :: c_cld_lw_abs(nlwbands, ncol, pver) ! combined cloud absorption optics depth (LW) - character(len=*), parameter :: sub = 'rrtmgp_set_cloud_lw' + character(len=*), parameter :: sub = 'rrtmgp_lw_cloud_optics_run' !-------------------------------------------------------------------------------- ! Combine the cloud optical properties. diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 new file mode 100644 index 0000000000..e94bdecc17 --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 @@ -0,0 +1,81 @@ +!> \file rrtmgp_lw_gas_optics.F90 +!! + +!> This module contains a run routine to compute gas optics during the radiation subcycle +module rrtmgp_lw_gas_optics + use machine, only: kind_phys + 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_1scl + use mo_source_functions, only: ty_source_func_lw + use radiation_tools, only: check_error_msg + + implicit none + + public :: rrtmgp_lw_gas_optics_run +contains + +!> \section arg_table_rrtmgp_lw_gas_optics_run Argument Table +!! \htmlinclude rrtmgp_lw_gas_optics_run.html +!! + subroutine rrtmgp_lw_gas_optics_run(dolw, iter_num, ncol, rrtmgp_phys_blksz, p_lay, p_lev, t_lay, tsfg, & + gas_concs, lw_optical_props_clrsky, sources, t_lev, include_interface_temp, lw_gas_props, & + errmsg, errflg) + ! Inputs + logical, intent(in) :: dolw + logical, intent(in) :: include_interface_temp + integer, intent(in) :: iter_num + integer, intent(in) :: ncol + integer, intent(in) :: rrtmgp_phys_blksz + real(kind_phys), dimension(:,:), intent(in) :: p_lay + real(kind_phys), dimension(:,:), intent(in) :: p_lev + real(kind_phys), dimension(:,:), intent(in) :: t_lay + real(kind_phys), dimension(:), intent(in) :: tsfg + real(kind_phys), dimension(:,:), intent(in) :: t_lev + type(ty_gas_concs), intent(in) :: gas_concs !< RRTMGP gas concentrations object + + ! Outputs + !type(ty_gas_concs), intent(in) :: gas_concs !< RRTMGP gas concentrations object + type(ty_optical_props_1scl), intent(inout) :: lw_optical_props_clrsky !< Clearsky optical properties + type(ty_source_func_lw), intent(inout) :: sources + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + type(ty_gas_optics_rrtmgp), intent(inout) :: lw_gas_props !< RRTMGP gas optics object + + ! Local variables + integer :: iCol, iCol2 + + ! Set error variables + errmsg = '' + errflg = 0 + + if (.not. dolw) then + return + end if + + iCol = ((iter_num - 1) * rrtmgp_phys_blksz) + 1 + iCol2= min(iCol + rrtmgp_phys_blksz - 1, ncol) + if (include_interface_temp) then + call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_optics(& + p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) + tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) + gas_concs, & ! IN - RRTMGP DDT: trace gas volume mixing-ratios + lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties + sources, & ! OUT - RRTMGP DDT: source functions + tlev=t_lev(iCol:iCol2,:))) ! IN - Temperature @ layer-interfaces (K) (optional) + else + call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_optics(& + p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) + tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) + gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties + sources)) ! OUT - RRTMGP DDT: source functions + end if + + end subroutine rrtmgp_lw_gas_optics_run + +end module rrtmgp_lw_gas_optics diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 new file mode 100644 index 0000000000..519c26ddfe --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 @@ -0,0 +1,98 @@ +!> \file rrtmgp_lw_gas_optics_data.F90 +!! + +!> This module contains an init routine to initialize the gas optics object +!> with data read in from file on the host side +module rrtmgp_lw_gas_optics_data + use machine, only: kind_phys + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_gas_concentrations, only: ty_gas_concs +! use radiation_tools, only: check_error_msg + + implicit none + + +contains +!> \section arg_table_rrtmgp_lw_gas_optics_data_init Argument Table +!! \htmlinclude rrtmgp_lw_gas_optics_data_init.html +!! + subroutine rrtmgp_lw_gas_optics_data_init(kdist, 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, & + errmsg, errflg) + + ! Inputs + class(ty_gas_concs), intent(in) :: available_gases + character(len=*), dimension(:), intent(in) :: gas_names + character(len=*), dimension(:), intent(in) :: gas_minor + character(len=*), dimension(:), intent(in) :: identifier_minor + character(len=*), dimension(:), intent(in) :: minor_gases_lower + character(len=*), dimension(:), intent(in) :: minor_gases_upper + character(len=*), dimension(:), intent(in) :: scaling_gas_lower + character(len=*), dimension(:), intent(in) :: scaling_gas_upper + integer, dimension(:,:,:), intent(in) :: key_species + integer, dimension(:,:), intent(in) :: band2gpt + integer, dimension(:,:), intent(in) :: minor_limits_gpt_lower + integer, dimension(:,:), intent(in) :: minor_limits_gpt_upper + integer, dimension(:), intent(in) :: kminor_start_lower + integer, dimension(:), intent(in) :: kminor_start_upper + logical, dimension(:), intent(in) :: minor_scales_with_density_lower + logical, dimension(:), intent(in) :: scale_by_complement_lower + logical, dimension(:), intent(in) :: minor_scales_with_density_upper + logical, dimension(:), intent(in) :: scale_by_complement_upper + real(kind_phys), dimension(:,:,:,:), intent(in) :: kmajor + real(kind_phys), dimension(:,:,:,:), intent(in) :: planck_frac + real(kind_phys), dimension(:,:,:), intent(in) :: kminor_lower + real(kind_phys), dimension(:,:,:), intent(in) :: kminor_upper + real(kind_phys), dimension(:,:,:), intent(in) :: vmr_ref + real(kind_phys), dimension(:,:,:), allocatable, intent(in) :: rayl_lower + real(kind_phys), dimension(:,:,:), allocatable, intent(in) :: rayl_upper + real(kind_phys), dimension(:,:), intent(in) :: band_lims_wavenum + real(kind_phys), dimension(:,:), intent(in) :: totplnk + real(kind_phys), dimension(:,:), intent(in) :: optimal_angle_fit + real(kind_phys), dimension(:), intent(in) :: press_ref + real(kind_phys), dimension(:), intent(in) :: temp_ref + real(kind_phys), intent(in) :: press_ref_trop + real(kind_phys), intent(in) :: temp_ref_p + real(kind_phys), intent(in) :: temp_ref_t + + ! Outputs + class(ty_gas_optics_rrtmgp), intent(inout) :: kdist !< RRTMGP gas optics object + character(len=*), intent(out) :: errmsg !< CCPP error message + integer, intent(out) :: errflg !< CCPP error code + + ! Initialize error variables + errmsg = '' + errflg = 0 + + ! Initialize the gas optics object with data. + errmsg = 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) + + if (len_trim(errmsg) > 0) then + errflg = 1 + end if + + end subroutine rrtmgp_lw_gas_optics_data_init + +end module rrtmgp_lw_gas_optics_data diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 new file mode 100644 index 0000000000..8edb6c867d --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 @@ -0,0 +1,191 @@ +!> \file rrtmgp_lw_gas_optics_pre.F90 +!! + +!> This module contains an init routine to initialize the k-distribution data +!! and functions needed to compute the longwave gaseous optical properties in RRTMGP. +!! It also contains a run routine to compute gas optics during the radiation subcycle +module rrtmgp_lw_gas_optics_pre + use machine, only: kind_phys + use mo_gas_concentrations, only: ty_gas_concs + + implicit none + + public :: rrtmgp_lw_gas_optics_pre_run +contains + +!> \section arg_table_rrtmgp_lw_gas_optics_pre_run Argument Table +!! \htmlinclude rrtmgp_lw_gas_optics_pre_run.html +!! + subroutine rrtmgp_lw_gas_optics_pre_run(icall, rad_const_array, pmid, pint, nlay, ncol, gaslist, idxday, & + pverp, ktoprad, ktopcam, dolw, nradgas, gas_concs, errmsg, errflg) + + ! 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. + + integer, intent(in) :: icall ! index of climate/diagnostic radiation call + character(len=*), intent(in) :: gaslist(:) + integer, intent(in) :: nlay ! number of layers in radiation calculation + integer, intent(in) :: ncol ! number of columns, ncol for LW, nday for SW + integer, intent(in) :: pverp + integer, intent(in) :: idxday(:) ! indices of daylight columns in a chunk + integer, intent(in) :: ktoprad + integer, intent(in) :: ktopcam + integer, intent(in) :: nradgas + logical, intent(in) :: dolw + real(kind_phys), intent(in) :: pmid(:,:) + real(kind_phys), intent(in) :: pint(:,:) + real(kind_phys), intent(in) :: rad_const_array(:,:,:) ! array of radiatively-active constituent vmrs + ! last index corresponds to index in gaslist + + type(ty_gas_concs), intent(inout) :: gas_concs ! the result is VRM inside gas_concs + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i, gas_idx, idx(ncol) + integer :: istat + real(kind_phys) :: gas_mmr(ncol, nlay) + real(kind_phys) :: gas_vmr(ncol, nlay) + real(kind_phys) :: mmr(ncol, nlay) + real(kind_phys) :: massratio + character(len=256) :: alloc_errmsg + + ! For ozone profile above model + real(kind_phys) :: P_top, P_int, P_mid, alpha, beta, a, b, chi_mid, chi_0, chi_eff + + character(len=*), parameter :: sub = 'rrtmgp_lw_gas_optics_pre_run' + !---------------------------------------------------------------------------- + + ! Set error variables + errmsg = '' + errflg = 0 + + if (.not. dolw) then + return + end if + + ! set the column indices; just count for longwave + do i = 1, ncol + idx(i) = i + end do + + do gas_idx = 1, nradgas + + ! grab mass mixing ratio of gas + gas_mmr = rad_const_array(:,:,gas_idx) + + do i = 1, ncol + 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 + + ! special case: H2O is specific humidity, not mixing ratio. Use r = q/(1-q): + if (gaslist(gas_idx) == 'H2O') then + mmr = mmr / (1._kind_phys - mmr) + end if + + ! convert MMR to VMR, multipy by ratio of dry air molar mas to gas molar mass. + call get_molar_mass_ratio(gaslist(gas_idx), massratio, errmsg, errflg) + if (errflg /= 0) then + return + end if + gas_vmr = mmr * massratio + + ! 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 ((gaslist(gas_idx) == 'O3') .and. (nlay == pverp)) then + P_top = 50.0_kind_phys + do i = 1, ncol + P_int = pint(idx(i),1) ! pressure (Pa) at upper interface of CAM + P_mid = pmid(idx(i),1) ! pressure (Pa) at midpoint of top layer of CAM + alpha = log(P_int/P_top) + beta = log(P_mid/P_int)/log(P_mid/P_top) + + a = ( (1._kind_phys + alpha) * exp(-alpha) - 1._kind_phys ) / alpha + b = 1._kind_phys - exp(-alpha) + + 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._kind_phys + beta) + chi_eff = chi_0 * (a + b) + gas_vmr(i,1) = chi_eff + end if + end do + end if + + errmsg = gas_concs%set_vmr(gaslist(gas_idx), gas_vmr) + if (len_trim(errmsg) > 0) then + errflg = 1 + return + end if + +! deallocate(gas_vmr) +! deallocate(mmr) + end do + + end subroutine rrtmgp_lw_gas_optics_pre_run + +!========================================================================================= + + subroutine get_molar_mass_ratio(gas_name, massratio, errmsg, errflg) + + ! return the molar mass ratio of dry air to gas based on gas_name + + character(len=*), intent(in) :: gas_name + real(kind_phys), intent(out) :: massratio + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind_phys), parameter :: amdw = 1.607793_kind_phys ! Molecular weight of dry air / water vapor + real(kind_phys), parameter :: amdc = 0.658114_kind_phys ! Molecular weight of dry air / carbon dioxide + real(kind_phys), parameter :: amdo = 0.603428_kind_phys ! Molecular weight of dry air / ozone + real(kind_phys), parameter :: amdm = 1.805423_kind_phys ! Molecular weight of dry air / methane + real(kind_phys), parameter :: amdn = 0.658090_kind_phys ! Molecular weight of dry air / nitrous oxide + real(kind_phys), parameter :: amdo2 = 0.905140_kind_phys ! Molecular weight of dry air / oxygen + real(kind_phys), parameter :: amdc1 = 0.210852_kind_phys ! Molecular weight of dry air / CFC11 + real(kind_phys), parameter :: amdc2 = 0.239546_kind_phys ! Molecular weight of dry air / CFC12 + + character(len=*), parameter :: sub='get_molar_mass_ratio' + !---------------------------------------------------------------------------- + ! Set error variables + errmsg = '' + errflg = 0 + + select case (trim(gas_name)) + case ('H2O') + massratio = amdw + case ('CO2') + massratio = amdc + case ('O3') + massratio = amdo + case ('CH4') + massratio = amdm + case ('N2O') + massratio = amdn + case ('O2') + massratio = amdo2 + case ('CFC11') + massratio = amdc1 + case ('CFC12') + massratio = amdc2 + case default + write(errmsg, '(a,a,a)') sub, ': Invalid gas: ', trim(gas_name) + errflg = 1 + end select + +end subroutine get_molar_mass_ratio + + +end module rrtmgp_lw_gas_optics_pre diff --git a/src/physics/rrtmgp/rrtmgp_lw_main.F90 b/src/physics/rrtmgp/rrtmgp_lw_main.F90 new file mode 100644 index 0000000000..c304d4b3f4 --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_lw_main.F90 @@ -0,0 +1,226 @@ +!> \file rrtmgp_lw_main.F90 +!! This file contains the longwave RRTMGP radiation scheme. + +!> This module contains the call to the RRTMGP-LW radiation scheme +module rrtmgp_lw_main + use machine, only: kind_phys + use mo_rte_lw, only: rte_lw + use mo_fluxes_byband, only: ty_fluxes_byband + use mo_optical_props, only: ty_optical_props_arry + use mo_fluxes_byband, only: ty_fluxes_byband + use mo_fluxes, only: ty_fluxes + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_source_functions, only: ty_source_func_lw + use radiation_tools, only: check_error_msg + implicit none + + public rrtmgp_lw_main_run +contains + +!> \section arg_table_rrtmgp_lw_main_run Argument Table +!! \htmlinclude rrtmgp_lw_main_run.html +!! + subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, use_LW_optimal_angles, & + nGauss_angles, nCol, iter_num, rrtmgp_phys_blksz, lw_optical_props_clrsky, & + lw_optical_props_clouds, top_at_1, sources, sfc_emiss_byband, lw_gas_props, & + aerlw, fluxlwUP_jac, lw_Ds, flux_clrsky, flux_allsky, errmsg, errflg) + + ! Inputs + logical, intent(in) :: doLWrad ! Flag to perform longwave calculation + logical, intent(in) :: doLWclrsky ! Flag to compute clear-sky fluxes + logical, intent(in) :: doGP_lwscat ! Flag to include scattering in clouds + logical, intent(in) :: use_LW_jacobian ! Flag to compute Jacobian + logical, intent(in) :: use_LW_optimal_angles ! Flag to compute and use optimal angles + logical, intent(in) :: top_at_1 ! Flag for vertical ordering convention + + integer, intent(in) :: nGauss_angles ! Number of gaussian quadrature angles used + integer, intent(in) :: nCol ! Number of horizontal points + integer, intent(in) :: iter_num ! RRTMGP iteration number + integer, intent(in) :: rrtmgp_phys_blksz ! Number of horizontal points to process at once + + real(kind_phys), dimension(:,:), intent(out) :: lw_Ds + real(kind_phys), dimension(:,:), intent(in) :: sfc_emiss_byband + + type(ty_source_func_lw), intent(in) :: sources + + ! Outputs + real(kind_phys), dimension(:,:), intent(inout) :: fluxlwUP_jac + class(ty_fluxes), intent(inout) :: flux_allsky + class(ty_fluxes), intent(inout) :: flux_clrsky + class(ty_optical_props_arry), intent(inout) :: aerlw + class(ty_optical_props_arry), intent(inout) :: lw_optical_props_clrsky + class(ty_optical_props_arry), intent(inout) :: lw_optical_props_clouds + + type(ty_gas_optics_rrtmgp), intent(inout) :: lw_gas_props + + character(len=*), intent(out) :: errmsg ! CCPP error message + integer, intent(out) :: errflg ! CCPP error flag + + ! Local variables + integer :: iCol, iCol2 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. doLWrad) return + + iCol = ((iter_num - 1) * rrtmgp_phys_blksz) + 1 + iCol2 = min(iCol + rrtmgp_phys_blksz - 1, nCol) + + ! ################################################################################### + ! + ! Compute clear-sky fluxes (gaseous+aerosol) (optional) + ! + ! ################################################################################### + ! Increment + !lw_optical_props_aerosol_local%tau = aerlw_tau(iCol:iCol2,:,:) + call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky',& + aerlw%increment(lw_optical_props_clrsky)) + + ! Call RTE solver + if (doLWclrsky) then + if (nGauss_angles .gt. 1) then + call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_clrsky, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + else + if (use_lw_optimal_angles) then + call check_error_msg('rrtmgp_lw_main_opt_angle',& + lw_gas_props%compute_optimal_angles(lw_optical_props_clrsky,lw_Ds)) + call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_clrsky, & ! OUT - Fluxes + lw_Ds = lw_Ds)) + else + call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_clrsky)) ! OUT - Fluxes + end if + endif + end if + + ! ################################################################################### + ! + ! All-sky fluxes (clear-sky + clouds + precipitation) + ! *Note* CCPP does not allow for polymorphic types, they are ambiguous to the CCPP + ! framework. rte-rrtmgp uses polymorphic types extensively, for example, querying the + ! type to determine physics configuration/pathway/etc... + ! + ! The logic in the code below is to satisfy the polymorphishm in the rte-rrtmgp code. + ! The rte-rrtmgp "increment" procedures are utilized to provide the correct type to the + ! rte solver (rte_lw). Rte_lw quieries the type determine if scattering is to be + ! included in the calculation. The increment procedures are called so that the correct + ! optical properties are inherited. + ! + ! ################################################################################### + + ! Include LW cloud-scattering? + if (doGP_lwscat) then + ! Increment + call check_error_msg('rrtmgp_lw_main_increment_clrsky_to_clouds',& + lw_optical_props_clrsky%increment(lw_optical_props_clouds)) + + if (use_LW_jacobian) then + if (nGauss_angles .gt. 1) then + ! Compute LW Jacobians; use Gaussian angles + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & + lw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature + flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + else + ! Compute LW Jacobians; don't use Gaussian angles + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & + lw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Fluxes + flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + end if + else + if (nGauss_angles .gt. 1) then + ! Compute LW Jacobians; use Gaussian angles + ! Don't compute LW Jacobians; use Gaussian angles + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & + lw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + else + ! Don't compute LW Jacobians; don't use Gaussian angles + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & + lw_optical_props_clouds, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky)) ! OUT - Fluxes + end if + end if + ! No scattering in LW clouds. + else + ! Increment + call check_error_msg('rrtmgp_lw_main_increment_clouds_to_clrsky', & + lw_optical_props_clouds%increment(lw_optical_props_clrsky)) + + if (use_LW_jacobian) then + if (nGauss_angles .gt. 1) then + ! Compute LW Jacobians; use Gaussian angles + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature + flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + else + ! Compute LW Jacobians; don't use Gaussian angles + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Fluxes + flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + end if + else + if (nGauss_angles .gt. 1) then + ! Don't compute LW Jacobians; use Gaussian angles + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + else + ! Don't compute LW Jacobians; don't use Gaussian angles + call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & + lw_optical_props_clrsky, & ! IN - optical-properties + top_at_1, & ! IN - veritcal ordering flag + sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky)) ! OUT - Fluxes + end if + end if + end if + + end subroutine rrtmgp_lw_main_run +end module rrtmgp_lw_main diff --git a/src/physics/rrtmgp/rrtmgp_post.F90 b/src/physics/rrtmgp/rrtmgp_post.F90 new file mode 100644 index 0000000000..c3c4705d1c --- /dev/null +++ b/src/physics/rrtmgp/rrtmgp_post.F90 @@ -0,0 +1,101 @@ +module rrtmgp_post + + use ccpp_kinds, only: kind_phys + 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 + + public :: rrtmgp_post_run + +contains +!> \section arg_table_rrtmgp_post_run Argument Table +!! \htmlinclude rrtmgp_post_run.html +!! +subroutine rrtmgp_post_run(ncol, qrs, qrl, pdel, atm_optics_sw, cloud_sw, aer_sw, & + fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, errmsg, errflg) + integer, intent(in) :: ncol + real(kind_phys), dimension(:,:), intent(in) :: pdel + real(kind_phys), dimension(:,:), intent(inout) :: qrs + real(kind_phys), dimension(:,:), intent(inout) :: qrl + type(ty_optical_props_2str), intent(inout) :: atm_optics_sw + type(ty_optical_props_1scl), intent(inout) :: aer_lw + type(ty_optical_props_2str), intent(inout) :: aer_sw + type(ty_optical_props_1scl), intent(inout) :: cloud_lw + type(ty_optical_props_2str), intent(inout) :: cloud_sw + type(ty_fluxes_broadband), intent(inout) :: fswc + type(ty_fluxes_broadband), intent(inout) :: flwc + type(ty_fluxes_byband), intent(inout) :: fsw + type(ty_fluxes_byband), intent(inout) :: flw + type(ty_source_func_lw), intent(inout) :: sources_lw + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Set error varaibles + errflg = 0 + errmsg = '' + ! The radiative heating rates are carried in the physics buffer across timesteps + ! as Q*dp (for energy conservation). + qrs(:ncol,:) = qrs(:ncol,:) * pdel(:ncol,:) + qrl(:ncol,:) = qrl(:ncol,:) * pdel(:ncol,:) + call free_optics_sw(atm_optics_sw) + call free_optics_sw(cloud_sw) + call free_optics_sw(aer_sw) + 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) + call free_fluxes(flwc) + +end subroutine rrtmgp_post_run + + !========================================================================================= + +subroutine free_optics_sw(optics) + + 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) + + 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) + + 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) + + 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 + + +end module rrtmgp_post diff --git a/src/physics/rrtmgp/rrtmgp_pre.F90 b/src/physics/rrtmgp/rrtmgp_pre.F90 index ff213d6684..8ad43bf5d5 100644 --- a/src/physics/rrtmgp/rrtmgp_pre.F90 +++ b/src/physics/rrtmgp/rrtmgp_pre.F90 @@ -1,6 +1,7 @@ module rrtmgp_pre use ccpp_kinds, only: kind_phys - use cam_logfile, only: iulog + use mo_fluxes, only: ty_fluxes_broadband + use mo_fluxes_byband, only: ty_fluxes_byband public :: rrtmgp_pre_run public :: radiation_do_ccpp @@ -11,25 +12,36 @@ module rrtmgp_pre !! \htmlinclude rrtmgp_pre_run.html !! subroutine rrtmgp_pre_run(coszrs, nstep, dtime, iradsw, iradlw, irad_always, ncol, & - nextsw_cday, idxday, nday, idxnite, nnite, dosw, dolw, errmsg, errflg) + nextsw_cday, idxday, nday, idxnite, nnite, dosw, dolw, nlay, nlwbands, & + nswbands, spectralflux, fsw, fswc, flw, flwc, errmsg, errflg) use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use time_manager, only: get_curr_calday + ! Inputs real(kind_phys), dimension(:), intent(in) :: coszrs - integer, intent(in) :: dtime - integer, intent(in) :: nstep - integer, intent(in) :: iradsw - integer, intent(in) :: iradlw - integer, intent(in) :: irad_always - integer, intent(in) :: ncol - integer, intent(out) :: nday - integer, intent(out) :: nnite - real(kind_phys), intent(out) :: nextsw_cday - integer, dimension(:), intent(out) :: idxday - integer, dimension(:), intent(out) :: idxnite - logical, intent(out) :: dosw - logical, intent(out) :: dolw - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: dtime + integer, intent(in) :: nstep + integer, intent(in) :: iradsw + integer, intent(in) :: iradlw + integer, intent(in) :: irad_always + integer, intent(in) :: ncol + integer, intent(in) :: nlay + integer, intent(in) :: nlwbands + integer, intent(in) :: nswbands + logical, intent(in) :: spectralflux + ! Outputs + class(ty_fluxes_broadband), intent(out) :: fswc + class(ty_fluxes_broadband), intent(out) :: fsw + class(ty_fluxes_broadband), intent(out) :: flwc + class(ty_fluxes_broadband), intent(out) :: flw + integer, intent(out) :: nday + integer, intent(out) :: nnite + real(kind_phys), intent(out) :: nextsw_cday + integer, dimension(:), intent(out) :: idxday + integer, dimension(:), intent(out) :: idxnite + logical, intent(out) :: dosw + logical, intent(out) :: dolw + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! Local variables integer :: idx @@ -93,6 +105,25 @@ subroutine rrtmgp_pre_run(coszrs, nstep, dtime, iradsw, iradlw, irad_always, nco caldayp1 = get_curr_calday(offset=int(dtime)) if (caldayp1 /= nextsw_cday) nextsw_cday = -1._kind_phys end if + + ! Allocate the flux arrays and init to zero. + call initialize_rrtmgp_fluxes(nday, nlay+1, nswbands, nswbands, spectralflux, fsw, errmsg, errflg, do_direct=.true.) + if (errflg /= 0) then + return + end if + call initialize_rrtmgp_fluxes(nday, nlay+1, nswbands, nswbands, spectralflux, fswc, errmsg, errflg, do_direct=.true.) + if (errflg /= 0) then + return + end if + call initialize_rrtmgp_fluxes(ncol, nlay+1, nlwbands, nswbands, spectralflux, flw, errmsg, errflg) + if (errflg /= 0) then + return + end if + call initialize_rrtmgp_fluxes(ncol, nlay+1, nlwbands, nswbands, spectralflux, flwc, errmsg, errflg) + if (errflg /= 0) then + return + end if + end subroutine rrtmgp_pre_run !================================================================================================ @@ -131,4 +162,125 @@ subroutine radiation_do_ccpp(op, nstep, irad, irad_always, radiation_do, errmsg, end subroutine radiation_do_ccpp +!========================================================================================= + +subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, nswbands, spectralflux, fluxes, errmsg, errflg, do_direct) + + ! Allocate flux arrays and set values to zero. + + ! Arguments + integer, intent(in) :: ncol, nlevels, nbands, nswbands + logical, intent(in) :: spectralflux + class(ty_fluxes_broadband), intent(inout) :: fluxes + logical, optional, intent(in) :: do_direct + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + logical :: do_direct_local + character(len=256) :: alloc_errmsg + character(len=*), parameter :: sub = 'initialize_rrtmgp_fluxes' + !---------------------------------------------------------------------------- + + if (present(do_direct)) then + do_direct_local = .true. + else + do_direct_local = .false. + end if + + ! Broadband fluxes + allocate(fluxes%flux_up(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_up". Message: ', & + alloc_errmsg + return + end if + allocate(fluxes%flux_dn(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_dn". Message: ', & + alloc_errmsg + return + end if + allocate(fluxes%flux_net(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_net". Message: ', & + alloc_errmsg + return + end if + if (do_direct_local) then + allocate(fluxes%flux_dn_dir(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_dn_dir". Message: ', & + alloc_errmsg + return + end if + 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=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_up". Message: ', & + alloc_errmsg + return + end if + allocate(fluxes%bnd_flux_dn(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_dn". Message: ', & + alloc_errmsg + return + end if + allocate(fluxes%bnd_flux_net(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_net". Message: ', & + alloc_errmsg + return + end if + if (do_direct_local) then + allocate(fluxes%bnd_flux_dn_dir(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_dn_dir". Message: ', & + alloc_errmsg + return + end if + end if + end if + end select + + ! Initialize + call reset_fluxes(fluxes) + +end subroutine initialize_rrtmgp_fluxes + +!========================================================================================= + +subroutine reset_fluxes(fluxes) + + ! Reset flux arrays to zero. + + class(ty_fluxes_broadband), intent(inout) :: fluxes + !---------------------------------------------------------------------------- + + ! Reset broadband fluxes + fluxes%flux_up(:,:) = 0._kind_phys + fluxes%flux_dn(:,:) = 0._kind_phys + fluxes%flux_net(:,:) = 0._kind_phys + if (associated(fluxes%flux_dn_dir)) fluxes%flux_dn_dir(:,:) = 0._kind_phys + + select type (fluxes) + type is (ty_fluxes_byband) + ! Reset band-by-band fluxes + if (associated(fluxes%bnd_flux_up)) fluxes%bnd_flux_up(:,:,:) = 0._kind_phys + if (associated(fluxes%bnd_flux_dn)) fluxes%bnd_flux_dn(:,:,:) = 0._kind_phys + if (associated(fluxes%bnd_flux_net)) fluxes%bnd_flux_net(:,:,:) = 0._kind_phys + if (associated(fluxes%bnd_flux_dn_dir)) fluxes%bnd_flux_dn_dir(:,:,:) = 0._kind_phys + end select + +end subroutine reset_fluxes + +!========================================================================================= + end module rrtmgp_pre From 67a533608e315a7be34b9d0e67d09cd3e52e06d5 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Thu, 27 Mar 2025 17:21:24 -0600 Subject: [PATCH 06/17] add initial attempt at type wrappers; code runs but answers are wrong --- src/physics/rrtmgp/ccpp_fluxes.F90 | 17 ++ src/physics/rrtmgp/ccpp_fluxes.meta | 7 + src/physics/rrtmgp/ccpp_fluxes_byband.F90 | 12 + src/physics/rrtmgp/ccpp_fluxes_byband.meta | 7 + .../rrtmgp/ccpp_gas_concentrations.F90 | 11 + .../rrtmgp/ccpp_gas_concentrations.meta | 7 + src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 | 10 + .../rrtmgp/ccpp_gas_optics_rrtmgp.meta | 7 + src/physics/rrtmgp/ccpp_optical_props.F90 | 22 ++ src/physics/rrtmgp/ccpp_optical_props.meta | 15 + src/physics/rrtmgp/ccpp_source_functions.F90 | 11 + src/physics/rrtmgp/ccpp_source_functions.meta | 7 + src/physics/rrtmgp/radconstants.F90 | 1 - src/physics/rrtmgp/radiation.F90 | 257 +++++------------- src/physics/rrtmgp/radiation_tools.F90 | 98 +++++++ src/physics/rrtmgp/rrtmgp_inputs.F90 | 48 ++-- src/physics/rrtmgp/rrtmgp_inputs_cam.F90 | 22 +- src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 | 8 +- src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 | 33 ++- .../rrtmgp/rrtmgp_lw_gas_optics_data.F90 | 13 +- .../rrtmgp/rrtmgp_lw_gas_optics_pre.F90 | 8 +- .../rrtmgp/rrtmgp_lw_initialize_fluxes.F90 | 180 ------------ src/physics/rrtmgp/rrtmgp_lw_main.F90 | 81 +++--- .../rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 | 8 +- src/physics/rrtmgp/rrtmgp_post.F90 | 91 ++++--- src/physics/rrtmgp/rrtmgp_pre.F90 | 195 ++++++++----- 26 files changed, 584 insertions(+), 592 deletions(-) create mode 100644 src/physics/rrtmgp/ccpp_fluxes.F90 create mode 100644 src/physics/rrtmgp/ccpp_fluxes.meta create mode 100644 src/physics/rrtmgp/ccpp_fluxes_byband.F90 create mode 100644 src/physics/rrtmgp/ccpp_fluxes_byband.meta create mode 100644 src/physics/rrtmgp/ccpp_gas_concentrations.F90 create mode 100644 src/physics/rrtmgp/ccpp_gas_concentrations.meta create mode 100644 src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 create mode 100644 src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.meta create mode 100644 src/physics/rrtmgp/ccpp_optical_props.F90 create mode 100644 src/physics/rrtmgp/ccpp_optical_props.meta create mode 100644 src/physics/rrtmgp/ccpp_source_functions.F90 create mode 100644 src/physics/rrtmgp/ccpp_source_functions.meta create mode 100644 src/physics/rrtmgp/radiation_tools.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_lw_initialize_fluxes.F90 diff --git a/src/physics/rrtmgp/ccpp_fluxes.F90 b/src/physics/rrtmgp/ccpp_fluxes.F90 new file mode 100644 index 0000000000..5ec4a2b840 --- /dev/null +++ b/src/physics/rrtmgp/ccpp_fluxes.F90 @@ -0,0 +1,17 @@ +module ccpp_fluxes + ! CCPP wrapper for ty_fluxes DDT from RRTMGP + use mo_fluxes, only: ty_fluxes + use mo_fluxes, only: ty_fluxes_broadband + + !> \section arg_table_ty_fluxes_ccpp Argument Table + !! \htmlinclude ty_fluxes_ccpp.html +! type, public, aibstract, extends(ty_fluxes) :: ty_fluxes_ccpp +! end type + + !> \section arg_table_ty_fluxes_broadband_ccpp Argument Table + !! \htmlinclude ty_fluxes_broadband_ccpp.html + type, public :: ty_fluxes_broadband_ccpp + type(ty_fluxes_broadband) :: fluxes + end type + +end module ccpp_fluxes diff --git a/src/physics/rrtmgp/ccpp_fluxes.meta b/src/physics/rrtmgp/ccpp_fluxes.meta new file mode 100644 index 0000000000..e2e5b6fcc4 --- /dev/null +++ b/src/physics/rrtmgp/ccpp_fluxes.meta @@ -0,0 +1,7 @@ +[ccpp-table-properties] + name = ty_fluxes_broadband_ccpp + type = ddt + +[ccpp-arg-table] + name = ty_fluxes_broadband_ccpp + type = ddt diff --git a/src/physics/rrtmgp/ccpp_fluxes_byband.F90 b/src/physics/rrtmgp/ccpp_fluxes_byband.F90 new file mode 100644 index 0000000000..6212efbfaa --- /dev/null +++ b/src/physics/rrtmgp/ccpp_fluxes_byband.F90 @@ -0,0 +1,12 @@ +module ccpp_fluxes_byband + ! CCPP wrapper for ty_fluxes_byband DDT from RRTMGP + use mo_fluxes_byband, only: ty_fluxes_byband + use ccpp_fluxes, only: ty_fluxes_broadband_ccpp + + !> \section arg_table_ty_fluxes_byband_ccpp Argument Table + !! \htmlinclude ty_fluxes_byband_ccpp.html + type, public :: ty_fluxes_byband_ccpp + type(ty_fluxes_byband) :: fluxes + end type + +end module ccpp_fluxes_byband diff --git a/src/physics/rrtmgp/ccpp_fluxes_byband.meta b/src/physics/rrtmgp/ccpp_fluxes_byband.meta new file mode 100644 index 0000000000..6645fc1b16 --- /dev/null +++ b/src/physics/rrtmgp/ccpp_fluxes_byband.meta @@ -0,0 +1,7 @@ +[ccpp-table-properties] + name = ty_fluxes_byband_ccpp + type = ddt + +[ccpp-arg-table] + name = ty_fluxes_byband_ccpp + type = ddt diff --git a/src/physics/rrtmgp/ccpp_gas_concentrations.F90 b/src/physics/rrtmgp/ccpp_gas_concentrations.F90 new file mode 100644 index 0000000000..3b3dd96ee2 --- /dev/null +++ b/src/physics/rrtmgp/ccpp_gas_concentrations.F90 @@ -0,0 +1,11 @@ +module ccpp_gas_concentrations + ! CCPP wrapper for ty_gas_concs DDT from RRTMGP + use mo_gas_concentrations, only: ty_gas_concs + + !> \section arg_table_ty_gas_concs_ccpp Argument Table + !! \htmlinclude ty_gas_concs_ccpp.html + type, public :: ty_gas_concs_ccpp + type(ty_gas_concs) :: gas_concs + end type + +end module ccpp_gas_concentrations diff --git a/src/physics/rrtmgp/ccpp_gas_concentrations.meta b/src/physics/rrtmgp/ccpp_gas_concentrations.meta new file mode 100644 index 0000000000..1bb7f38640 --- /dev/null +++ b/src/physics/rrtmgp/ccpp_gas_concentrations.meta @@ -0,0 +1,7 @@ +[ccpp-table-properties] + name = ty_gas_concs_ccpp + type = ddt + +[ccpp-arg-table] + name = ty_gas_concs_ccpp + type = ddt diff --git a/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 b/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 new file mode 100644 index 0000000000..c1ae872a0f --- /dev/null +++ b/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 @@ -0,0 +1,10 @@ +module ccpp_gas_optics_rrtmgp + ! CCPP wrapper for ty_gas_optics_rrtmgp DDT from RRTMGP + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + + !> \section arg_table_ty_gas_optics_rrtmgp_ccpp Argument Table + !! \htmlinclude ty_gas_optics_rrtmgp_ccpp.html + type, public, extends(ty_gas_optics_rrtmgp) :: ty_gas_optics_rrtmgp_ccpp + end type + +end module ccpp_gas_optics_rrtmgp diff --git a/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.meta b/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.meta new file mode 100644 index 0000000000..66e0f08dc7 --- /dev/null +++ b/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.meta @@ -0,0 +1,7 @@ +[ccpp-table-properties] + name = ty_gas_optics_rrtmgp_ccpp + type = ddt + +[ccpp-arg-table] + name = ty_gas_optics_rrtmgp_ccpp + type = ddt diff --git a/src/physics/rrtmgp/ccpp_optical_props.F90 b/src/physics/rrtmgp/ccpp_optical_props.F90 new file mode 100644 index 0000000000..57c57a67e3 --- /dev/null +++ b/src/physics/rrtmgp/ccpp_optical_props.F90 @@ -0,0 +1,22 @@ +module ccpp_optical_props + ! CCPP wrapper for ty_optical_props_* DDTs from RRTMGP + use mo_optical_props, only: ty_optical_props_1scl + use mo_optical_props, only: ty_optical_props_2str + use mo_optical_props, only: ty_optical_props_arry + + !> \section arg_table_ty_optical_props_1scl_ccpp Argument Table + !! \htmlinclude ty_optical_props_1scl_ccpp.html + type, public, extends(ty_optical_props_1scl) :: ty_optical_props_1scl_ccpp + end type + + !> \section arg_table_ty_optical_props_2str_ccpp Argument Table + !! \htmlinclude ty_optical_props_2str_ccpp.html + type, public, extends(ty_optical_props_2str) :: ty_optical_props_2str_ccpp + end type + + !> \section arg_table_ty_optical_props_arry_ccpp Argument Table + !! \htmlinclude ty_optical_props_arry_ccpp.html + type, public, abstract, extends(ty_optical_props_arry) :: ty_optical_props_arry_ccpp + end type + +end module ccpp_optical_props diff --git a/src/physics/rrtmgp/ccpp_optical_props.meta b/src/physics/rrtmgp/ccpp_optical_props.meta new file mode 100644 index 0000000000..564fbc3c07 --- /dev/null +++ b/src/physics/rrtmgp/ccpp_optical_props.meta @@ -0,0 +1,15 @@ +[ccpp-table-properties] + name = ty_optical_props_1scl_ccpp + type = ddt + +[ccpp-arg-table] + name = ty_optical_props_1scl_ccpp + type = ddt + +[ccpp-table-properties] + name = ty_optical_props_2str_ccpp + type = ddt + +[ccpp-arg-table] + name = ty_optical_props_2str_ccpp + type = ddt diff --git a/src/physics/rrtmgp/ccpp_source_functions.F90 b/src/physics/rrtmgp/ccpp_source_functions.F90 new file mode 100644 index 0000000000..56e65e3ded --- /dev/null +++ b/src/physics/rrtmgp/ccpp_source_functions.F90 @@ -0,0 +1,11 @@ +module ccpp_source_functions + ! CCPP wrapper for ty_source_func_lw DDT from RRTMGP + use mo_source_functions, only: ty_source_func_lw + + !> \section arg_table_ty_source_func_lw_ccpp Argument Table + !! \htmlinclude ty_source_func_lw_ccpp.html + type, public :: ty_source_func_lw_ccpp + type(ty_source_func_lw) :: sources + end type + +end module ccpp_source_functions diff --git a/src/physics/rrtmgp/ccpp_source_functions.meta b/src/physics/rrtmgp/ccpp_source_functions.meta new file mode 100644 index 0000000000..b0fd2380ea --- /dev/null +++ b/src/physics/rrtmgp/ccpp_source_functions.meta @@ -0,0 +1,7 @@ +[ccpp-table-properties] + name = ty_source_func_lw_ccpp + type = ddt + +[ccpp-arg-table] + name = ty_source_func_lw_ccpp + type = ddt diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index dd13caa397..0edf9772e2 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -4,7 +4,6 @@ module radconstants ! code used in the RRTMGP model. use shr_kind_mod, only: r8 => shr_kind_r8 -use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use cam_abortutils, only: endrun use radiation_utils, only: get_sw_spectral_boundaries_ccpp use radiation_utils, only: get_lw_spectral_boundaries_ccpp diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 149e4d65c8..7baf39b6c9 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -46,12 +46,12 @@ module radiation pio_def_var, pio_put_var, pio_get_var, & pio_put_att, PIO_NOWRITE, pio_closefile -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, only: ty_fluxes_broadband -use mo_fluxes_byband, only: ty_fluxes_byband +use ccpp_gas_concentrations, only: ty_gas_concs_ccpp +use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp +use ccpp_optical_props, only: ty_optical_props_1scl_ccpp, ty_optical_props_2str_ccpp +use ccpp_source_functions, only: ty_source_func_lw_ccpp +use ccpp_fluxes, only: ty_fluxes_broadband_ccpp +use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp use string_utils, only: to_lower use cam_abortutils, only: endrun, handle_allocate_error @@ -240,8 +240,8 @@ module radiation logical :: dolw ! 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 +type(ty_gas_optics_rrtmgp_ccpp) :: kdist_sw +type(ty_gas_optics_rrtmgp_ccpp) :: kdist_lw ! lower case version of gaslist for RRTMGP character(len=gasnamelength) :: gaslist_lc(nradgas) @@ -425,7 +425,7 @@ subroutine radiation_init(pbuf2d) ! names of gases that are available in the model ! -- needed for the kdist initialization routines - type(ty_gas_concs) :: available_gases + type(ty_gas_concs_ccpp) :: available_gases real(r8) :: qrl_unused(1,1) @@ -444,14 +444,15 @@ subroutine radiation_init(pbuf2d) character(len=*), parameter :: sub = 'radiation_init' !----------------------------------------------------------------------- - ! Create lowercase version of the gaslist for RRTMGP. The ty_gas_concs objects + ! Create lowercase version of the gaslist for RRTMGP. The ty_gas_concs_ccpp 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) + ! PEVERWHEE - add this to new rrtmgp_pre_iinit routine (possible also above code?) + errmsg = available_gases%gas_concs%init(gaslist_lc) call stop_on_err(errmsg, sub, 'available_gases%init') ! Read RRTMGP coefficients files and initialize kdist objects. @@ -813,7 +814,6 @@ subroutine radiation_tend( & use rrtmgp_inputs, only: rrtmgp_inputs_run use rrtmgp_pre, only: rrtmgp_pre_run - use rrtmgp_lw_initialize_fluxes, only: rrtmgp_lw_initialize_fluxes_run use rrtmgp_lw_cloud_optics, only: rrtmgp_lw_cloud_optics_run use rrtmgp_lw_mcica_subcol_gen, only: rrtmgp_lw_mcica_subcol_gen_run use rrtmgp_lw_gas_optics_pre, only: rrtmgp_lw_gas_optics_pre_run @@ -936,36 +936,36 @@ subroutine radiation_tend( & real(r8), allocatable :: sfac(:,:) ! Planck sources for LW. - type(ty_source_func_lw) :: sources_lw + type(ty_source_func_lw_ccpp) :: sources_lw ! 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 + type(ty_gas_concs_ccpp) :: gas_concs_lw + type(ty_gas_concs_ccpp) :: gas_concs_sw ! 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 + type(ty_optical_props_1scl_ccpp) :: atm_optics_lw + type(ty_optical_props_2str_ccpp) :: atm_optics_sw ! Cloud optical properties objects (McICA sampling of cloud optical properties). - type(ty_optical_props_1scl) :: cloud_lw - type(ty_optical_props_2str) :: cloud_sw + type(ty_optical_props_1scl_ccpp) :: cloud_lw + type(ty_optical_props_2str_ccpp) :: cloud_sw ! Aerosol optical properties objects. - type(ty_optical_props_1scl) :: aer_lw - type(ty_optical_props_2str) :: aer_sw + type(ty_optical_props_1scl_ccpp) :: aer_lw + type(ty_optical_props_2str_ccpp) :: aer_sw ! 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 + type(ty_fluxes_byband_ccpp) :: fsw ! LW allsky fluxes only need spectrally resolved fluxes when spectralflux=.true. - type(ty_fluxes_byband) :: flw + type(ty_fluxes_byband_ccpp) :: flw ! Only broadband fluxes needed for clear sky (diagnostics). - type(ty_fluxes_broadband) :: fswc, flwc + type(ty_fluxes_broadband_ccpp) :: fswc, flwc ! Arrays for output diagnostics on CAM grid. real(r8) :: fns(pcols,pverp) ! net shortwave flux @@ -1143,7 +1143,7 @@ subroutine radiation_tend( & ! 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, & + pmid_day, pint_day, t_day, gas_concs_sw%gas_concs, atm_optics_sw, & toa_flux) call stop_on_err(errmsg, sub, 'kdist_sw%gas_optics') @@ -1168,7 +1168,7 @@ subroutine radiation_tend( & ! Compute clear-sky fluxes. errmsg = rte_sw(& atm_optics_sw, top_at_1, coszrs_day, toa_flux, & - alb_dir, alb_dif, fswc) + alb_dir, alb_dif, fswc%fluxes) 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. @@ -1178,7 +1178,7 @@ subroutine radiation_tend( & ! Compute all-sky fluxes. errmsg = rte_sw(& atm_optics_sw, top_at_1, coszrs_day, toa_flux, & - alb_dir, alb_dif, fsw) + alb_dir, alb_dif, fsw%fluxes) call stop_on_err(errmsg, sub, 'all-sky rte_sw') end if @@ -1388,9 +1388,9 @@ subroutine set_sw_diags() ! full chunks for output to CAM history. 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 + real(r8), dimension(size(fsw%fluxes%bnd_flux_dn,1), & + size(fsw%fluxes%bnd_flux_dn,2), & + size(fsw%fluxes%bnd_flux_dn,3)) :: flux_dn_diffuse !------------------------------------------------------------------------- ! Initialize to provide 0.0 values for night columns. @@ -1415,18 +1415,18 @@ subroutine set_sw_diags() 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:) - 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) - 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:) - 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:) + fns(idxday(i),ktopcam:) = fsw%fluxes%flux_net(i, ktoprad:) + fcns(idxday(i),ktopcam:) = fswc%fluxes%flux_net(i,ktoprad:) + fsds(idxday(i)) = fsw%fluxes%flux_dn(i, nlay+1) + rd%fsdsc(idxday(i)) = fswc%fluxes%flux_dn(i, nlay+1) + rd%fsutoa(idxday(i)) = fsw%fluxes%flux_up(i, 1) + rd%fsntoa(idxday(i)) = fsw%fluxes%flux_net(i, 1) + rd%fsntoac(idxday(i)) = fswc%fluxes%flux_net(i, 1) + rd%solin(idxday(i)) = fswc%fluxes%flux_dn(i, 1) + rd%flux_sw_up(idxday(i),ktopcam:) = fsw%fluxes%flux_up(i,ktoprad:) + rd%flux_sw_dn(idxday(i),ktopcam:) = fsw%fluxes%flux_dn(i,ktoprad:) + rd%flux_sw_clr_up(idxday(i),ktopcam:) = fswc%fluxes%flux_up(i,ktoprad:) + rd%flux_sw_clr_dn(idxday(i),ktopcam:) = fswc%fluxes%flux_dn(i,ktoprad:) end do ! Compute heating rate as a dry static energy tendency. @@ -1453,8 +1453,8 @@ subroutine set_sw_diags() su = 0._r8 sd = 0._r8 do i = 1, nday - su(idxday(i),ktopcam:,:) = fsw%bnd_flux_up(i,ktoprad:,:) - sd(idxday(i),ktopcam:,:) = fsw%bnd_flux_dn(i,ktoprad:,:) + su(idxday(i),ktopcam:,:) = fsw%fluxes%bnd_flux_up(i,ktoprad:,:) + sd(idxday(i),ktopcam:,:) = fsw%fluxes%bnd_flux_dn(i,ktoprad:,:) end do end if @@ -1473,14 +1473,14 @@ subroutine set_sw_diags() 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 + flux_dn_diffuse = fsw%fluxes%bnd_flux_dn - fsw%fluxes%bnd_flux_dn_dir do i = 1, nday - 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%soll(idxday(i)) = sum(fsw%fluxes%bnd_flux_dn_dir(i,nlay+1,1:9)) & + + 0.5_r8 * fsw%fluxes%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%sols(idxday(i)) = 0.5_r8 * fsw%fluxes%bnd_flux_dn_dir(i,nlay+1,10) & + + sum(fsw%fluxes%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) @@ -1502,13 +1502,13 @@ subroutine set_lw_diags() fcnl = 0._r8 ! RTE-RRTMGP convention for net is (down - up) **CAM assumes (up - down) !! - fnl(:ncol,ktopcam:) = -1._r8 * flw%flux_net( :, ktoprad:) - fcnl(:ncol,ktopcam:) = -1._r8 * flwc%flux_net( :, ktoprad:) + fnl(:ncol,ktopcam:) = -1._r8 * flw%fluxes%flux_net( :, ktoprad:) + fcnl(:ncol,ktopcam:) = -1._r8 * flwc%fluxes%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:) + rd%flux_lw_up(:ncol,ktopcam:) = flw%fluxes%flux_up( :, ktoprad:) + rd%flux_lw_clr_up(:ncol,ktopcam:) = flwc%fluxes%flux_up(:, ktoprad:) + rd%flux_lw_dn(:ncol,ktopcam:) = flw%fluxes%flux_dn( :, ktoprad:) + rd%flux_lw_clr_dn(:ncol,ktopcam:) = flwc%fluxes%flux_dn(:, ktoprad:) call heating_rate('LW', ncol, fnl, qrl) call heating_rate('LW', ncol, fcnl, rd%qrlc) @@ -1519,11 +1519,11 @@ subroutine set_lw_diags() rd%flnsc(:ncol) = fcnl(:ncol, pverp) 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) + cam_out%flwds(:ncol) = flw%fluxes%flux_dn(:, nlay+1) + rd%fldsc(:ncol) = flwc%fluxes%flux_dn(:, nlay+1) - rd%flut(:ncol) = flw%flux_up(:, ktoprad) - rd%flutc(:ncol) = flwc%flux_up(:, ktoprad) + rd%flut(:ncol) = flw%fluxes%flux_up(:, ktoprad) + rd%flutc(:ncol) = flwc%fluxes%flux_up(:, ktoprad) ! Output fluxes at 200 mb call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) @@ -1537,8 +1537,8 @@ subroutine set_lw_diags() if (spectralflux) then lu = 0._r8 ld = 0._r8 - lu(:ncol, ktopcam:, :) = flw%bnd_flux_up(:, ktoprad:, :) - ld(:ncol, ktopcam:, :) = flw%bnd_flux_dn(:, ktoprad:, :) + lu(:ncol, ktopcam:, :) = flw%fluxes%bnd_flux_up(:, ktoprad:, :) + ld(:ncol, ktopcam:, :) = flw%fluxes%bnd_flux_dn(:, ktoprad:, :) end if end subroutine set_lw_diags @@ -1745,8 +1745,8 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ! arguments character(len=*), intent(in) :: coefs_file - class(ty_gas_concs), intent(in) :: available_gases - class(ty_gas_optics_rrtmgp), intent(inout) :: kdist + class(ty_gas_concs_ccpp), intent(in) :: available_gases + class(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: kdist ! local variables type(file_desc_t) :: fh ! pio file handle @@ -2234,7 +2234,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) end if else if (allocated(solar_src_quiet)) then error_msg = kdist%load( & - available_gases, gas_names, key_species, & + available_gases%gas_concs, gas_names, key_species, & band2gpt, band_lims_wavenum, & press_ref, press_ref_trop, temp_ref, & temp_ref_p, temp_ref_t, vmr_ref, & @@ -2287,135 +2287,6 @@ end subroutine coefs_init !========================================================================================= -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 - class(ty_fluxes_broadband), intent(inout) :: fluxes - logical, optional, intent(in) :: do_direct - - ! Local variables - logical :: do_direct_local - integer :: istat - character(len=*), parameter :: sub = 'initialize_rrtmgp_fluxes' - !---------------------------------------------------------------------------- - - if (present(do_direct)) then - do_direct_local = .true. - else - do_direct_local = .false. - end if - - ! Broadband fluxes - allocate(fluxes%flux_up(ncol, nlevels), stat=istat) - call handle_allocate_error(istat, sub, 'fluxes%flux_up') - allocate(fluxes%flux_dn(ncol, nlevels), stat=istat) - call handle_allocate_error(istat, sub, 'fluxes%flux_dn') - allocate(fluxes%flux_net(ncol, nlevels), stat=istat) - call handle_allocate_error(istat, sub, 'fluxes%flux_net') - if (do_direct_local) then - allocate(fluxes%flux_dn_dir(ncol, nlevels), stat=istat) - call handle_allocate_error(istat, sub, 'fluxes%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 handle_allocate_error(istat, sub, 'fluxes%bnd_flux_up') - allocate(fluxes%bnd_flux_dn(ncol, nlevels, nbands), stat=istat) - call handle_allocate_error(istat, sub, 'fluxes%bnd_flux_dn') - allocate(fluxes%bnd_flux_net(ncol, nlevels, nbands), stat=istat) - 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 handle_allocate_error(istat, sub, 'fluxes%bnd_flux_dn_dir') - end if - end if - end select - - ! Initialize - call reset_fluxes(fluxes) - -end subroutine initialize_rrtmgp_fluxes - -!========================================================================================= - -subroutine reset_fluxes(fluxes) - - ! Reset flux arrays to zero. - - 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)) 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 - -!========================================================================================= - -subroutine free_optics_sw(optics) - - 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) - - 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) - - 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) - - 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 - -!========================================================================================= - subroutine stop_on_err(errmsg, sub, info) ! call endrun if RRTMGP function returns non-empty error message. diff --git a/src/physics/rrtmgp/radiation_tools.F90 b/src/physics/rrtmgp/radiation_tools.F90 new file mode 100644 index 0000000000..e941a34615 --- /dev/null +++ b/src/physics/rrtmgp/radiation_tools.F90 @@ -0,0 +1,98 @@ +!>\file radiation_tools.F90 +!! + +!> This module contains tools for radiation +module radiation_tools + use machine, only: & + kind_phys ! Working type + implicit none + + real(kind_phys) :: & + rrtmgp_minP, & ! Minimum pressure allowed in RRTMGP + rrtmgp_minT ! Minimum temperature allowed in RRTMGP +contains + +!> + subroutine cmp_tlev(nCol,nLev,minP,p_lay,t_lay,p_lev,tsfc,t_lev) + ! Inputs + integer, intent(in) :: & + nCol,nLev + real(kind_phys),intent(in) :: & + minP + real(kind_phys),dimension(nCol),intent(in) :: & + tsfc + real(kind_phys),dimension(nCol,nLev),intent(in) :: & + p_lay,t_lay + real(kind_phys),dimension(nCol,nLev+1),intent(in) :: & + p_lev + + ! Outputs + real(kind_phys),dimension(nCol,nLev+1),intent(out) :: & + t_lev + + ! Local + integer :: iCol,iLay, iSFC, iTOA + logical :: top_at_1 + real(kind_phys), dimension(nCol,nLev) :: tem2da, tem2db + + top_at_1 = (p_lev(1,1) .lt. p_lev(1, nLev)) + if (top_at_1) then + iSFC = nLev + iTOA = 1 + else + iSFC = 1 + iTOA = nLev + endif + + if (iTOA .eq. 1) then + tem2da(1:nCol,2:iSFC) = log(p_lay(1:nCol,2:iSFC)) + tem2db(1:nCol,2:iSFC) = log(p_lev(1:nCol,2:iSFC)) + do iCol = 1, nCol + tem2da(iCol,1) = log(p_lay(iCol,1) ) + tem2db(iCol,1) = log(max(minP, p_lev(iCol,1)) ) + tem2db(iCol,iSFC) = log(p_lev(iCol,iSFC) ) + enddo + t_lev(1:NCOL,1) = t_lay(1:NCOL,iTOA) + do iLay = 2, iSFC + do iCol = 1, nCol + t_lev(iCol,iLay) = t_lay(iCol,iLay) + (t_lay(iCol,iLay-1) - t_lay(iCol,iLay))& + * (tem2db(iCol,iLay) - tem2da(iCol,iLay)) & + / (tem2da(iCol,iLay-1) - tem2da(iCol,iLay)) + enddo + enddo + t_lev(1:NCOL,iSFC+1) = tsfc(1:NCOL) + else + tem2da(1:nCol,2:iTOA) = log(p_lay(1:nCol,2:iTOA)) + tem2db(1:nCol,2:iTOA) = log(p_lev(1:nCol,2:iTOA)) + do iCol = 1, nCol + tem2da(iCol,1) = log(p_lay(iCol,1)) + tem2db(iCol,1) = log(p_lev(iCol,1)) + tem2db(iCol,iTOA) = log(max(minP, p_lev(iCol,iTOA)) ) + enddo + + t_lev(1:NCOL,1) = tsfc(1:NCOL) + do iLay = 1, iTOA-1 + do iCol = 1, nCol + t_lev(iCol,iLay+1) = t_lay(iCol,iLay) + (t_lay(iCol,iLay+1) - t_lay(iCol,iLay))& + * (tem2db(iCol,iLay+1) - tem2da(iCol,iLay)) & + / (tem2da(iCol,iLay+1) - tem2da(iCol,iLay)) + enddo + enddo + t_lev(1:NCOL,iTOA+1) = t_lay(1:NCOL,iTOA) + endif + + end subroutine cmp_tlev + +!> + subroutine check_error_msg(routine_name, error_msg) + character(len=*), intent(in) :: & + error_msg, routine_name + + if(error_msg /= "") then + print*,"ERROR("//trim(routine_name)//"): " + print*,trim(error_msg) + return + end if + end subroutine check_error_msg + +end module radiation_tools diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 7589929fe9..a3129265d0 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -1,9 +1,9 @@ module rrtmgp_inputs use machine, only: kind_phys - 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_gas_concentrations, only: ty_gas_concs - use mo_source_functions, only: ty_source_func_lw + use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp + use ccpp_optical_props, only: ty_optical_props_1scl_ccpp, ty_optical_props_2str_ccpp + use ccpp_gas_concentrations, only: ty_gas_concs_ccpp + use ccpp_source_functions, only: ty_source_func_lw_ccpp use string_utils, only: to_lower use radiation_utils, only: radiation_utils_init, get_sw_spectral_boundaries_ccpp @@ -37,8 +37,8 @@ subroutine rrtmgp_inputs_init(ktopcam, ktoprad, nlaycam, sw_low_bounds, sw_high_ integer, intent(in) :: gasnamelength real(kind_phys), intent(in) :: current_cal_day real(kind_phys), dimension(:), intent(in) :: pref_edge - type(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw - type(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw + type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw + type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw logical, intent(in) :: is_first_step logical, intent(in) :: is_first_restart_step logical, intent(in) :: use_rad_dt_cosz @@ -79,12 +79,6 @@ subroutine rrtmgp_inputs_init(ktopcam, ktoprad, nlaycam, sw_low_bounds, sw_high_ errflg = 0 errmsg = '' - ! Read RRTMGP coefficients files and initialize kdist objects. - ! peverwhee - Will be inputs to rrtmgp_gas_optics_init -! call coefs_init(coefs_sw_file, available_gases, kdist_sw) -! call coefs_init(coefs_lw_file, available_gases, kdist_lw) - - ! 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 @@ -204,8 +198,8 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & real(kind_phys), dimension(:), intent(in) :: aldir real(kind_phys), dimension(:), intent(in) :: aldif real(kind_phys), intent(in) :: stebol ! stefan-boltzmann constant - class(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw ! spectral information - class(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw ! spectral information + type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw ! spectral information + type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw ! spectral information character(len=*), dimension(:), intent(in) :: gaslist ! Outputs real(kind_phys), dimension(:,:), intent(out) :: t_rad @@ -221,13 +215,13 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & real(kind_phys), dimension(:), intent(out) :: t_sfc real(kind_phys), dimension(:), intent(out) :: coszrs_day - type(ty_gas_concs), intent(out) :: gas_concs_lw - type(ty_optical_props_1scl), intent(out) :: atm_optics_lw - type(ty_optical_props_1scl), intent(out) :: aer_lw - type(ty_source_func_lw), intent(out) :: sources_lw - type(ty_gas_concs), intent(out) :: gas_concs_sw - type(ty_optical_props_2str), intent(out) :: atm_optics_sw - type(ty_optical_props_2str), intent(out) :: aer_sw + type(ty_gas_concs_ccpp), intent(out) :: gas_concs_lw + type(ty_optical_props_1scl_ccpp), intent(out) :: atm_optics_lw + type(ty_optical_props_1scl_ccpp), intent(out) :: aer_lw + type(ty_source_func_lw_ccpp), intent(out) :: sources_lw + type(ty_gas_concs_ccpp), intent(out) :: gas_concs_sw + type(ty_optical_props_2str_ccpp), intent(out) :: atm_optics_sw + type(ty_optical_props_2str_ccpp), intent(out) :: aer_sw character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -370,7 +364,7 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & end do end if - ! Create lowercase version of the gaslist for RRTMGP. The ty_gas_concs objects + ! Create lowercase version of the gaslist for RRTMGP. The ty_gas_concs_ccpp objects ! work with CAM's uppercase names, but other objects that get input from the gas ! concs objects don't work. do idx = 1, size(gaslist) @@ -380,7 +374,7 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & ! If no daylight columns, can't create empty RRTMGP objects if (dosw .and. nday > 0) then ! Initialize object for gas concentrations. - errmsg = gas_concs_sw%init(gaslist_lc) + errmsg = gas_concs_sw%gas_concs%init(gaslist_lc) if (len_trim(errmsg) > 0) then errflg = 1 return @@ -405,7 +399,7 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & if (dolw) then ! Initialize object for gas concentrations - errmsg = gas_concs_lw%init(gaslist_lc) + errmsg = gas_concs_lw%gas_concs%init(gaslist_lc) if (len_trim(errmsg) > 0) then errflg = 1 return @@ -426,7 +420,7 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & end if ! Initialize object for Planck sources. - errmsg = sources_lw%alloc(ncol, nlay, kdist_lw) + errmsg = sources_lw%sources%alloc(ncol, nlay, kdist_lw) if (len_trim(errmsg) > 0) then errflg = 1 return @@ -449,8 +443,8 @@ subroutine set_wavenumber_bands(kdist_sw, kdist_lw, nswbands, nlwbands, idx_sw_d ! Set band indices for bands containing specific wavelengths. ! Arguments - type(ty_gas_optics_rrtmgp), intent(in) :: kdist_sw - type(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw + type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw + type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw integer, intent(in) :: nswbands integer, intent(in) :: nlwbands diff --git a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 index 1c1f0a9d67..849e072f47 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 @@ -30,9 +30,9 @@ module rrtmgp_inputs_cam 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 ccpp_gas_concentrations, only: ty_gas_concs_ccpp +use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp +use ccpp_optical_props, only: ty_optical_props_2str_ccpp, ty_optical_props_1scl_ccpp use cam_history_support, only: fillvalue use cam_abortutils, only: endrun @@ -167,7 +167,7 @@ subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, ga 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 + type(ty_gas_concs_ccpp), intent(inout) :: gas_concs ! the result is VRM inside gas_concs integer, optional, intent(in) :: idxday(:) ! indices of daylight columns in a chunk @@ -250,7 +250,7 @@ subroutine rad_gas_get_vmr(icall, gas_name, state, pbuf, nlay, numactivecols, ga end do end if - errmsg = gas_concs%set_vmr(gas_name, gas_vmr) + errmsg = gas_concs%gas_concs%set_vmr(gas_name, gas_vmr) if (len_trim(errmsg) > 0) then call endrun(sub//': ERROR, gas_concs%set_vmr: '//trim(errmsg)) end if @@ -302,7 +302,7 @@ subroutine rrtmgp_set_gases_sw( & integer, intent(in) :: nlay integer, intent(in) :: nday integer, intent(in) :: idxday(:) - type(ty_gas_concs), intent(inout) :: gas_concs + type(ty_gas_concs_ccpp), intent(inout) :: gas_concs ! local variables integer :: i @@ -346,9 +346,9 @@ subroutine rrtmgp_set_cloud_sw( & 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 ! SW cloud optical properties object + logical, intent(in) :: graupel_in_rad ! graupel in radiation code + class(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw ! shortwave gas optics object + type(ty_optical_props_2str_ccpp), 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 @@ -607,7 +607,7 @@ subroutine rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw) type(physics_state), target, intent(in) :: state type(physics_buffer_desc), pointer :: pbuf(:) - type(ty_optical_props_1scl), intent(inout) :: aer_lw + type(ty_optical_props_1scl_ccpp), intent(inout) :: aer_lw ! Local variables integer :: ncol @@ -652,7 +652,7 @@ subroutine rrtmgp_set_aer_sw( & 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 + type(ty_optical_props_2str_ccpp), intent(inout) :: aer_sw ! local variables integer :: i diff --git a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 index c1cfda7a5b..0cb7c739c7 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 @@ -13,8 +13,8 @@ module rrtmgp_lw_cloud_optics lininterp, extrap_method_bndry, & lininterp_finish use radiation_utils, only: get_mu_lambda_weights_ccpp - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_1scl + use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp + use ccpp_optical_props, only: ty_optical_props_1scl_ccpp implicit none public :: rrtmgp_lw_cloud_optics_run @@ -144,10 +144,10 @@ subroutine rrtmgp_lw_cloud_optics_run(ncol, nlay, nlaycam, cld, cldfsnow, cldfgr logical, intent(in) :: graupel_in_rad logical, intent(in) :: do_snow logical, intent(in) :: do_graupel - class(ty_gas_optics_rrtmgp), intent(in) :: kdist_lw + class(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw ! Outputs - type(ty_optical_props_1scl), intent(out) :: cloud_lw + type(ty_optical_props_1scl_ccpp), intent(out) :: cloud_lw real(kind_phys), dimension(:,:), intent(out) :: cld_lw_abs_cloudsim real(kind_phys), dimension(:,:), intent(out) :: snow_lw_abs_cloudsim real(kind_phys), dimension(:,:), intent(out) :: grau_lw_abs_cloudsim diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 index e94bdecc17..da5fe9df03 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 @@ -3,12 +3,12 @@ !> This module contains a run routine to compute gas optics during the radiation subcycle module rrtmgp_lw_gas_optics - use machine, only: kind_phys - 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_1scl - use mo_source_functions, only: ty_source_func_lw - use radiation_tools, only: check_error_msg + use machine, only: kind_phys + use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp + use ccpp_gas_concentrations, only: ty_gas_concs_ccpp + use ccpp_optical_props, only: ty_optical_props_1scl_ccpp + use ccpp_source_functions, only: ty_source_func_lw_ccpp + use radiation_tools, only: check_error_msg implicit none @@ -32,15 +32,14 @@ subroutine rrtmgp_lw_gas_optics_run(dolw, iter_num, ncol, rrtmgp_phys_blksz, p_l real(kind_phys), dimension(:,:), intent(in) :: t_lay real(kind_phys), dimension(:), intent(in) :: tsfg real(kind_phys), dimension(:,:), intent(in) :: t_lev - type(ty_gas_concs), intent(in) :: gas_concs !< RRTMGP gas concentrations object + class(ty_gas_concs_ccpp), intent(in) :: gas_concs !< RRTMGP gas concentrations object ! Outputs - !type(ty_gas_concs), intent(in) :: gas_concs !< RRTMGP gas concentrations object - type(ty_optical_props_1scl), intent(inout) :: lw_optical_props_clrsky !< Clearsky optical properties - type(ty_source_func_lw), intent(inout) :: sources - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - type(ty_gas_optics_rrtmgp), intent(inout) :: lw_gas_props !< RRTMGP gas optics object + class(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clrsky !< Clearsky optical properties + class(ty_source_func_lw_ccpp), intent(inout) :: sources + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + type(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: lw_gas_props !< RRTMGP gas optics object ! Local variables integer :: iCol, iCol2 @@ -61,9 +60,9 @@ subroutine rrtmgp_lw_gas_optics_run(dolw, iter_num, ncol, rrtmgp_phys_blksz, p_l p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) - gas_concs, & ! IN - RRTMGP DDT: trace gas volume mixing-ratios + gas_concs%gas_concs, & ! IN - RRTMGP DDT: trace gas volume mixing-ratios lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties - sources, & ! OUT - RRTMGP DDT: source functions + sources%sources, & ! OUT - RRTMGP DDT: source functions tlev=t_lev(iCol:iCol2,:))) ! IN - Temperature @ layer-interfaces (K) (optional) else call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_optics(& @@ -71,9 +70,9 @@ subroutine rrtmgp_lw_gas_optics_run(dolw, iter_num, ncol, rrtmgp_phys_blksz, p_l p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) - gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + gas_concs%gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties - sources)) ! OUT - RRTMGP DDT: source functions + sources%sources)) ! OUT - RRTMGP DDT: source functions end if end subroutine rrtmgp_lw_gas_optics_run diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 index 519c26ddfe..54f3904fb1 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 @@ -4,10 +4,9 @@ !> This module contains an init routine to initialize the gas optics object !> with data read in from file on the host side module rrtmgp_lw_gas_optics_data - use machine, only: kind_phys - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_gas_concentrations, only: ty_gas_concs -! use radiation_tools, only: check_error_msg + use machine, only: kind_phys + use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp + use ccpp_gas_concentrations, only: ty_gas_concs_ccpp implicit none @@ -28,7 +27,7 @@ subroutine rrtmgp_lw_gas_optics_data_init(kdist, available_gases, gas_names, errmsg, errflg) ! Inputs - class(ty_gas_concs), intent(in) :: available_gases + class(ty_gas_concs_ccpp), intent(in) :: available_gases character(len=*), dimension(:), intent(in) :: gas_names character(len=*), dimension(:), intent(in) :: gas_minor character(len=*), dimension(:), intent(in) :: identifier_minor @@ -63,7 +62,7 @@ subroutine rrtmgp_lw_gas_optics_data_init(kdist, available_gases, gas_names, real(kind_phys), intent(in) :: temp_ref_t ! Outputs - class(ty_gas_optics_rrtmgp), intent(inout) :: kdist !< RRTMGP gas optics object + class(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: kdist !< RRTMGP gas optics object character(len=*), intent(out) :: errmsg !< CCPP error message integer, intent(out) :: errflg !< CCPP error code @@ -73,7 +72,7 @@ subroutine rrtmgp_lw_gas_optics_data_init(kdist, available_gases, gas_names, ! Initialize the gas optics object with data. errmsg = kdist%load( & - available_gases, gas_names, key_species, & + available_gases%gas_concs, gas_names, key_species, & band2gpt, band_lims_wavenum, & press_ref, press_ref_trop, temp_ref, & temp_ref_p, temp_ref_t, vmr_ref, & diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 index 8edb6c867d..13164c0378 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 @@ -5,8 +5,8 @@ !! and functions needed to compute the longwave gaseous optical properties in RRTMGP. !! It also contains a run routine to compute gas optics during the radiation subcycle module rrtmgp_lw_gas_optics_pre - use machine, only: kind_phys - use mo_gas_concentrations, only: ty_gas_concs + use machine, only: kind_phys + use ccpp_gas_concentrations, only: ty_gas_concs_ccpp implicit none @@ -39,7 +39,7 @@ subroutine rrtmgp_lw_gas_optics_pre_run(icall, rad_const_array, pmid, pint, nlay real(kind_phys), intent(in) :: rad_const_array(:,:,:) ! array of radiatively-active constituent vmrs ! last index corresponds to index in gaslist - type(ty_gas_concs), intent(inout) :: gas_concs ! the result is VRM inside gas_concs + type(ty_gas_concs_ccpp), intent(inout) :: gas_concs ! the result is VRM inside gas_concs character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -124,7 +124,7 @@ subroutine rrtmgp_lw_gas_optics_pre_run(icall, rad_const_array, pmid, pint, nlay end do end if - errmsg = gas_concs%set_vmr(gaslist(gas_idx), gas_vmr) + errmsg = gas_concs%gas_concs%set_vmr(gaslist(gas_idx), gas_vmr) if (len_trim(errmsg) > 0) then errflg = 1 return diff --git a/src/physics/rrtmgp/rrtmgp_lw_initialize_fluxes.F90 b/src/physics/rrtmgp/rrtmgp_lw_initialize_fluxes.F90 deleted file mode 100644 index c3a367526f..0000000000 --- a/src/physics/rrtmgp/rrtmgp_lw_initialize_fluxes.F90 +++ /dev/null @@ -1,180 +0,0 @@ -module rrtmgp_lw_initialize_fluxes - - public :: rrtmgp_lw_initialize_fluxes_run - -contains -!> \section arg_table_rrtmgp_lw_initialize_fluxes_run Argument Table -!! \htmlinclude rrtmgp_lw_initialize_fluxes_run.html -!! - subroutine rrtmgp_lw_initialize_fluxes_run(rrtmgp_phys_blksz, nlay, nlwbands, spectralflux, flux_allsky, flux_clrsky, & - errmsg, errflg) - use mo_fluxes, only: ty_fluxes_broadband - use mo_fluxes_byband, only: ty_fluxes_byband - ! Inputs - integer, intent(in) :: rrtmgp_phys_blksz - integer, intent(in) :: nlay - integer, intent(in) :: nlwbands - logical, intent(in) :: spectralflux - ! Outputs - class(ty_fluxes_broadband), intent(out) :: flux_clrsky - class(ty_fluxes_broadband), intent(out) :: flux_allsky - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - character(len=256) :: alloc_errmsg - integer :: play - - play = nlay + 1 - - ! Set error variables - errmsg = '' - errflg = 0 - - ! Clearsky fluxes - allocate(flux_clrsky%flux_up(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%flux_up". Message: ', & - alloc_errmsg - return - end if - - allocate(flux_clrsky%flux_dn(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%flux_dn". Message: ', & - alloc_errmsg - return - end if - - allocate(flux_clrsky%flux_net(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%flux_net". Message: ', & - alloc_errmsg - return - end if - - select type (flux_clrsky) - type is (ty_fluxes_byband) - ! Only allocate when spectralflux is true. - if (spectralflux) then - allocate(flux_clrsky%bnd_flux_up(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%bnd_flux_up". Message: ', & - alloc_errmsg - return - end if - - allocate(flux_clrsky%bnd_flux_dn(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%bnd_flux_dn". Message: ', & - alloc_errmsg - return - end if - - allocate(flux_clrsky%bnd_flux_net(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_clrsky%bnd_flux_net". Message: ', & - alloc_errmsg - return - end if - end if - end select - - ! Initialize - call reset_fluxes(flux_clrsky) - - ! Allsky fluxes - allocate(flux_allsky%flux_up(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%flux_up". Message: ', & - alloc_errmsg - return - end if - - allocate(flux_allsky%flux_dn(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%flux_dn". Message: ', & - alloc_errmsg - return - end if - - allocate(flux_allsky%flux_net(rrtmgp_phys_blksz, play), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%flux_net". Message: ', & - alloc_errmsg - return - end if -! if (do_direct_local) then -! allocate(flux_allsky%flux_dn_dir(rrtmgp_phys_blksz, play), stat=errflg) -! call handle_allocate_error(errflg, sub, 'flux_allsky%flux_dn_dir') -! end if - - select type (flux_allsky) - type is (ty_fluxes_byband) - ! Fluxes by band always needed for SW. Only allocate for LW - ! when spectralflux is true. - if (spectralflux) then - allocate(flux_allsky%bnd_flux_up(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%bnd_flux_up". Message: ', & - alloc_errmsg - return - end if - - allocate(flux_allsky%bnd_flux_dn(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%bnd_flux_dn". Message: ', & - alloc_errmsg - return - end if - - allocate(flux_allsky%bnd_flux_net(rrtmgp_phys_blksz, play, nlwbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a)') 'rrtmgp_lw_initialize_fluxes_run: ERROR: failed to allocate "flux_allsky%bnd_flux_net". Message: ', & - alloc_errmsg - return - end if - ! if (do_direct) then - ! allocate(flux_allsky%bnd_flux_dn_dir(rrtmgp_phys_blksz, play, nlwbands), stat=errflg) - ! call handle_allocate_error(errflg, sub, 'flux_allsky%bnd_flux_dn_dir') - ! allocate(flux_allsky%bnd_flux_dn_dir(rrtmgp_phys_blksz, play, nbands), stat=errflg) - ! call handle_allocate_error(errflg, sub, 'flux_allsky%bnd_flux_dn_dir') - ! end if - end if - end select - - ! Initialize - call reset_fluxes(flux_allsky) - - end subroutine rrtmgp_lw_initialize_fluxes_run - -!========================================================================================= - - subroutine reset_fluxes(fluxes) - use mo_fluxes, only: ty_fluxes_broadband - use mo_fluxes_byband, only: ty_fluxes_byband - use ccpp_kinds, only: kind_phys - - ! Reset flux arrays to zero. - - class(ty_fluxes_broadband), intent(inout) :: fluxes - !---------------------------------------------------------------------------- - - ! Reset broadband fluxes - fluxes%flux_up(:,:) = 0._kind_phys - fluxes%flux_dn(:,:) = 0._kind_phys - fluxes%flux_net(:,:) = 0._kind_phys - if (associated(fluxes%flux_dn_dir)) fluxes%flux_dn_dir(:,:) = 0._kind_phys - - select type (fluxes) - type is (ty_fluxes_byband) - ! Reset band-by-band fluxes - if (associated(fluxes%bnd_flux_up)) fluxes%bnd_flux_up(:,:,:) = 0._kind_phys - if (associated(fluxes%bnd_flux_dn)) fluxes%bnd_flux_dn(:,:,:) = 0._kind_phys - if (associated(fluxes%bnd_flux_net)) fluxes%bnd_flux_net(:,:,:) = 0._kind_phys - if (associated(fluxes%bnd_flux_dn_dir)) fluxes%bnd_flux_dn_dir(:,:,:) = 0._kind_phys - end select - - end subroutine reset_fluxes - -end module rrtmgp_lw_initialize_fluxes diff --git a/src/physics/rrtmgp/rrtmgp_lw_main.F90 b/src/physics/rrtmgp/rrtmgp_lw_main.F90 index c304d4b3f4..b889447c6f 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_main.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_main.F90 @@ -3,15 +3,16 @@ !> This module contains the call to the RRTMGP-LW radiation scheme module rrtmgp_lw_main - use machine, only: kind_phys - use mo_rte_lw, only: rte_lw - use mo_fluxes_byband, only: ty_fluxes_byband - use mo_optical_props, only: ty_optical_props_arry - use mo_fluxes_byband, only: ty_fluxes_byband - use mo_fluxes, only: ty_fluxes - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_source_functions, only: ty_source_func_lw - use radiation_tools, only: check_error_msg + use machine, only: kind_phys + use mo_rte_lw, only: rte_lw + use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp + use ccpp_optical_props, only: ty_optical_props_arry_ccpp + use ccpp_optical_props, only: ty_optical_props_1scl_ccpp + use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp + use ccpp_fluxes, only: ty_fluxes_broadband_ccpp + use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp + use ccpp_source_functions, only: ty_source_func_lw_ccpp + use radiation_tools, only: check_error_msg implicit none public rrtmgp_lw_main_run @@ -41,17 +42,18 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, real(kind_phys), dimension(:,:), intent(out) :: lw_Ds real(kind_phys), dimension(:,:), intent(in) :: sfc_emiss_byband - type(ty_source_func_lw), intent(in) :: sources + class(ty_source_func_lw_ccpp), intent(in) :: sources + !class(ty_source_func_lw), intent(in) :: sources ! Outputs - real(kind_phys), dimension(:,:), intent(inout) :: fluxlwUP_jac - class(ty_fluxes), intent(inout) :: flux_allsky - class(ty_fluxes), intent(inout) :: flux_clrsky - class(ty_optical_props_arry), intent(inout) :: aerlw - class(ty_optical_props_arry), intent(inout) :: lw_optical_props_clrsky - class(ty_optical_props_arry), intent(inout) :: lw_optical_props_clouds + real(kind_phys), dimension(:,:), intent(inout) :: fluxlwUP_jac + class(ty_fluxes_byband_ccpp), intent(inout) :: flux_allsky + class(ty_fluxes_broadband_ccpp), intent(inout) :: flux_clrsky + class(ty_optical_props_1scl_ccpp), intent(inout) :: aerlw + class(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clrsky + class(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clouds - type(ty_gas_optics_rrtmgp), intent(inout) :: lw_gas_props + class(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: lw_gas_props character(len=*), intent(out) :: errmsg ! CCPP error message integer, intent(out) :: errflg ! CCPP error flag @@ -74,7 +76,6 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, ! ! ################################################################################### ! Increment - !lw_optical_props_aerosol_local%tau = aerlw_tau(iCol:iCol2,:,:) call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky',& aerlw%increment(lw_optical_props_clrsky)) @@ -84,9 +85,9 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky, & ! OUT - Fluxes + flux_clrsky%fluxes, & ! OUT - Fluxes n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature else if (use_lw_optimal_angles) then @@ -95,17 +96,17 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky, & ! OUT - Fluxes + flux_clrsky%fluxes, & ! OUT - Fluxes lw_Ds = lw_Ds)) else call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky)) ! OUT - Fluxes + flux_clrsky%fluxes)) ! OUT - Fluxes end if endif end if @@ -137,9 +138,9 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & lw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Fluxes + flux_allsky%fluxes, & ! OUT - Fluxes n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) else @@ -147,9 +148,9 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & lw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Fluxes + flux_allsky%fluxes, & ! OUT - Fluxes flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) end if else @@ -159,18 +160,18 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & lw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Fluxes + flux_allsky%fluxes, & ! OUT - Fluxes n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature else ! Don't compute LW Jacobians; don't use Gaussian angles call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & lw_optical_props_clouds, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky)) ! OUT - Fluxes + flux_allsky%fluxes)) ! OUT - Fluxes end if end if ! No scattering in LW clouds. @@ -185,9 +186,9 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Fluxes + flux_allsky%fluxes, & ! OUT - Fluxes n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) else @@ -195,9 +196,9 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Fluxes + flux_allsky%fluxes, & ! OUT - Fluxes flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) end if else @@ -206,18 +207,18 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky, & ! OUT - Fluxes + flux_allsky%fluxes, & ! OUT - Fluxes n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature else ! Don't compute LW Jacobians; don't use Gaussian angles call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & lw_optical_props_clrsky, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag - sources, & ! IN - source function + sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky)) ! OUT - Fluxes + flux_allsky%fluxes)) ! OUT - Fluxes end if end if end if diff --git a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 index fe2d3804f5..b7f8657d70 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 @@ -30,8 +30,8 @@ module rrtmgp_lw_mcica_subcol_gen use machine, only: kind_phys use shr_RandNum_mod, only: ShrKissRandGen -use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp -use mo_optical_props, only: ty_optical_props_1scl +use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp +use ccpp_optical_props, only: ty_optical_props_1scl_ccpp implicit none private @@ -60,7 +60,7 @@ subroutine rrtmgp_lw_mcica_subcol_gen_run( & ! number of subcolumns ! arguments - class(ty_gas_optics_rrtmgp), intent(in) :: kdist ! spectral information + class(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist ! spectral information integer, intent(in) :: ktoprad integer, intent(in) :: nbnd ! number of spectral bands integer, intent(in) :: ngpt ! number of subcolumns (g-point intervals) @@ -72,7 +72,7 @@ subroutine rrtmgp_lw_mcica_subcol_gen_run( & real(kind_phys), dimension(:,:), intent(in) :: pmid ! layer pressures (Pa) real(kind_phys), dimension(:,:), intent(in) :: cldfrac ! layer cloud fraction real(kind_phys), dimension(:,:,:), intent(in) :: tauc ! cloud optical depth - type(ty_optical_props_1scl), intent(inout) :: cloud_lw + type(ty_optical_props_1scl_ccpp), intent(inout) :: cloud_lw character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/src/physics/rrtmgp/rrtmgp_post.F90 b/src/physics/rrtmgp/rrtmgp_post.F90 index c3c4705d1c..ccf661ccc8 100644 --- a/src/physics/rrtmgp/rrtmgp_post.F90 +++ b/src/physics/rrtmgp/rrtmgp_post.F90 @@ -1,10 +1,10 @@ module rrtmgp_post use ccpp_kinds, only: kind_phys - 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 ccpp_optical_props, only: ty_optical_props_1scl_ccpp, ty_optical_props_2str_ccpp + use ccpp_source_functions, only: ty_source_func_lw_ccpp + use ccpp_fluxes, only: ty_fluxes_broadband_ccpp + use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp public :: rrtmgp_post_run @@ -14,22 +14,22 @@ module rrtmgp_post !! subroutine rrtmgp_post_run(ncol, qrs, qrl, pdel, atm_optics_sw, cloud_sw, aer_sw, & fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, errmsg, errflg) - integer, intent(in) :: ncol - real(kind_phys), dimension(:,:), intent(in) :: pdel - real(kind_phys), dimension(:,:), intent(inout) :: qrs - real(kind_phys), dimension(:,:), intent(inout) :: qrl - type(ty_optical_props_2str), intent(inout) :: atm_optics_sw - type(ty_optical_props_1scl), intent(inout) :: aer_lw - type(ty_optical_props_2str), intent(inout) :: aer_sw - type(ty_optical_props_1scl), intent(inout) :: cloud_lw - type(ty_optical_props_2str), intent(inout) :: cloud_sw - type(ty_fluxes_broadband), intent(inout) :: fswc - type(ty_fluxes_broadband), intent(inout) :: flwc - type(ty_fluxes_byband), intent(inout) :: fsw - type(ty_fluxes_byband), intent(inout) :: flw - type(ty_source_func_lw), intent(inout) :: sources_lw - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind_phys), dimension(:,:), intent(in) :: pdel + real(kind_phys), dimension(:,:), intent(inout) :: qrs + real(kind_phys), dimension(:,:), intent(inout) :: qrl + class(ty_optical_props_2str_ccpp), intent(inout) :: atm_optics_sw + class(ty_optical_props_1scl_ccpp), intent(inout) :: aer_lw + class(ty_optical_props_2str_ccpp), intent(inout) :: aer_sw + class(ty_optical_props_1scl_ccpp), intent(inout) :: cloud_lw + class(ty_optical_props_2str_ccpp), intent(inout) :: cloud_sw + class(ty_fluxes_broadband_ccpp), intent(inout) :: fswc + class(ty_fluxes_broadband_ccpp), intent(inout) :: flwc + class(ty_fluxes_byband_ccpp), intent(inout) :: fsw + class(ty_fluxes_byband_ccpp), intent(inout) :: flw + type(ty_source_func_lw_ccpp), intent(inout) :: sources_lw + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! Set error varaibles errflg = 0 @@ -41,14 +41,14 @@ subroutine rrtmgp_post_run(ncol, qrs, qrl, pdel, atm_optics_sw, cloud_sw, aer_sw call free_optics_sw(atm_optics_sw) call free_optics_sw(cloud_sw) call free_optics_sw(aer_sw) - call free_fluxes(fsw) - call free_fluxes(fswc) + call free_fluxes_byband(fsw) + call free_fluxes_broadband(fswc) - call sources_lw%finalize() + call sources_lw%sources%finalize() call free_optics_lw(cloud_lw) call free_optics_lw(aer_lw) - call free_fluxes(flw) - call free_fluxes(flwc) + call free_fluxes_byband(flw) + call free_fluxes_broadband(flwc) end subroutine rrtmgp_post_run @@ -56,7 +56,7 @@ end subroutine rrtmgp_post_run subroutine free_optics_sw(optics) - type(ty_optical_props_2str), intent(inout) :: optics + class(ty_optical_props_2str_ccpp), intent(inout) :: optics if (allocated(optics%tau)) deallocate(optics%tau) if (allocated(optics%ssa)) deallocate(optics%ssa) @@ -69,7 +69,7 @@ end subroutine free_optics_sw subroutine free_optics_lw(optics) - type(ty_optical_props_1scl), intent(inout) :: optics + class(ty_optical_props_1scl_ccpp), intent(inout) :: optics if (allocated(optics%tau)) deallocate(optics%tau) call optics%finalize() @@ -78,24 +78,33 @@ end subroutine free_optics_lw !========================================================================================= -subroutine free_fluxes(fluxes) +subroutine free_fluxes_broadband(fluxes) - class(ty_fluxes_broadband), intent(inout) :: fluxes + class(ty_fluxes_broadband_ccpp), 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%fluxes%flux_up)) deallocate(fluxes%fluxes%flux_up) + if (associated(fluxes%fluxes%flux_dn)) deallocate(fluxes%fluxes%flux_dn) + if (associated(fluxes%fluxes%flux_net)) deallocate(fluxes%fluxes%flux_net) + if (associated(fluxes%fluxes%flux_dn_dir)) deallocate(fluxes%fluxes%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_broadband -end subroutine free_fluxes +!========================================================================================= + +subroutine free_fluxes_byband(fluxes) + + class(ty_fluxes_byband_ccpp), intent(inout) :: fluxes + + if (associated(fluxes%fluxes%flux_up)) deallocate(fluxes%fluxes%flux_up) + if (associated(fluxes%fluxes%flux_dn)) deallocate(fluxes%fluxes%flux_dn) + if (associated(fluxes%fluxes%flux_net)) deallocate(fluxes%fluxes%flux_net) + if (associated(fluxes%fluxes%flux_dn_dir)) deallocate(fluxes%fluxes%flux_dn_dir) + + if (associated(fluxes%fluxes%bnd_flux_up)) deallocate(fluxes%fluxes%bnd_flux_up) + if (associated(fluxes%fluxes%bnd_flux_dn)) deallocate(fluxes%fluxes%bnd_flux_dn) + if (associated(fluxes%fluxes%bnd_flux_net)) deallocate(fluxes%fluxes%bnd_flux_net) + if (associated(fluxes%fluxes%bnd_flux_dn_dir)) deallocate(fluxes%fluxes%bnd_flux_dn_dir) +end subroutine free_fluxes_byband end module rrtmgp_post diff --git a/src/physics/rrtmgp/rrtmgp_pre.F90 b/src/physics/rrtmgp/rrtmgp_pre.F90 index 8ad43bf5d5..0918350eeb 100644 --- a/src/physics/rrtmgp/rrtmgp_pre.F90 +++ b/src/physics/rrtmgp/rrtmgp_pre.F90 @@ -1,7 +1,7 @@ module rrtmgp_pre use ccpp_kinds, only: kind_phys - use mo_fluxes, only: ty_fluxes_broadband - use mo_fluxes_byband, only: ty_fluxes_byband + use ccpp_fluxes, only: ty_fluxes_broadband_ccpp + use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp public :: rrtmgp_pre_run public :: radiation_do_ccpp @@ -14,7 +14,6 @@ module rrtmgp_pre subroutine rrtmgp_pre_run(coszrs, nstep, dtime, iradsw, iradlw, irad_always, ncol, & nextsw_cday, idxday, nday, idxnite, nnite, dosw, dolw, nlay, nlwbands, & nswbands, spectralflux, fsw, fswc, flw, flwc, errmsg, errflg) - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use time_manager, only: get_curr_calday ! Inputs real(kind_phys), dimension(:), intent(in) :: coszrs @@ -29,10 +28,10 @@ subroutine rrtmgp_pre_run(coszrs, nstep, dtime, iradsw, iradlw, irad_always, nco integer, intent(in) :: nswbands logical, intent(in) :: spectralflux ! Outputs - class(ty_fluxes_broadband), intent(out) :: fswc - class(ty_fluxes_broadband), intent(out) :: fsw - class(ty_fluxes_broadband), intent(out) :: flwc - class(ty_fluxes_broadband), intent(out) :: flw + class(ty_fluxes_broadband_ccpp), intent(out) :: fswc + class(ty_fluxes_byband_ccpp), intent(out) :: fsw + class(ty_fluxes_broadband_ccpp), intent(out) :: flwc + class(ty_fluxes_byband_ccpp), intent(out) :: flw integer, intent(out) :: nday integer, intent(out) :: nnite real(kind_phys), intent(out) :: nextsw_cday @@ -107,19 +106,19 @@ subroutine rrtmgp_pre_run(coszrs, nstep, dtime, iradsw, iradlw, irad_always, nco end if ! Allocate the flux arrays and init to zero. - call initialize_rrtmgp_fluxes(nday, nlay+1, nswbands, nswbands, spectralflux, fsw, errmsg, errflg, do_direct=.true.) + call initialize_rrtmgp_fluxes_byband(nday, nlay+1, nswbands, nswbands, spectralflux, fsw, errmsg, errflg, do_direct=.true.) if (errflg /= 0) then return end if - call initialize_rrtmgp_fluxes(nday, nlay+1, nswbands, nswbands, spectralflux, fswc, errmsg, errflg, do_direct=.true.) + call initialize_rrtmgp_fluxes_broadband(nday, nlay+1, nswbands, nswbands, spectralflux, fswc, errmsg, errflg, do_direct=.true.) if (errflg /= 0) then return end if - call initialize_rrtmgp_fluxes(ncol, nlay+1, nlwbands, nswbands, spectralflux, flw, errmsg, errflg) + call initialize_rrtmgp_fluxes_byband(ncol, nlay+1, nlwbands, nswbands, spectralflux, flw, errmsg, errflg) if (errflg /= 0) then return end if - call initialize_rrtmgp_fluxes(ncol, nlay+1, nlwbands, nswbands, spectralflux, flwc, errmsg, errflg) + call initialize_rrtmgp_fluxes_broadband(ncol, nlay+1, nlwbands, nswbands, spectralflux, flwc, errmsg, errflg) if (errflg /= 0) then return end if @@ -164,14 +163,14 @@ end subroutine radiation_do_ccpp !========================================================================================= -subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, nswbands, spectralflux, fluxes, errmsg, errflg, do_direct) +subroutine initialize_rrtmgp_fluxes_broadband(ncol, nlevels, nbands, nswbands, spectralflux, fluxes, errmsg, errflg, do_direct) ! Allocate flux arrays and set values to zero. ! Arguments integer, intent(in) :: ncol, nlevels, nbands, nswbands logical, intent(in) :: spectralflux - class(ty_fluxes_broadband), intent(inout) :: fluxes + class(ty_fluxes_broadband_ccpp), intent(inout) :: fluxes logical, optional, intent(in) :: do_direct character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -189,26 +188,26 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, nswbands, spectralflu end if ! Broadband fluxes - allocate(fluxes%flux_up(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + allocate(fluxes%fluxes%flux_up(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_up". Message: ', & alloc_errmsg return end if - allocate(fluxes%flux_dn(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + allocate(fluxes%fluxes%flux_dn(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_dn". Message: ', & alloc_errmsg return end if - allocate(fluxes%flux_net(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + allocate(fluxes%fluxes%flux_net(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_net". Message: ', & alloc_errmsg return end if if (do_direct_local) then - allocate(fluxes%flux_dn_dir(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + allocate(fluxes%fluxes%flux_dn_dir(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_dn_dir". Message: ', & alloc_errmsg @@ -216,70 +215,140 @@ subroutine initialize_rrtmgp_fluxes(ncol, nlevels, nbands, nswbands, spectralflu end if 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=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_up". Message: ', & - alloc_errmsg - return - end if - allocate(fluxes%bnd_flux_dn(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_dn". Message: ', & - alloc_errmsg - return - end if - allocate(fluxes%bnd_flux_net(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) + ! Initialize + call reset_fluxes_broadband(fluxes) + +end subroutine initialize_rrtmgp_fluxes_broadband + +!========================================================================================= + +subroutine initialize_rrtmgp_fluxes_byband(ncol, nlevels, nbands, nswbands, spectralflux, fluxes, errmsg, errflg, do_direct) + + ! Allocate flux arrays and set values to zero. + + ! Arguments + integer, intent(in) :: ncol, nlevels, nbands, nswbands + logical, intent(in) :: spectralflux + class(ty_fluxes_byband_ccpp), intent(inout) :: fluxes + logical, optional, intent(in) :: do_direct + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + logical :: do_direct_local + character(len=256) :: alloc_errmsg + character(len=*), parameter :: sub = 'initialize_rrtmgp_fluxes_byband' + !---------------------------------------------------------------------------- + + if (present(do_direct)) then + do_direct_local = .true. + else + do_direct_local = .false. + end if + + ! Broadband fluxes + allocate(fluxes%fluxes%flux_up(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_up". Message: ', & + alloc_errmsg + return + end if + allocate(fluxes%fluxes%flux_dn(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_dn". Message: ', & + alloc_errmsg + return + end if + allocate(fluxes%fluxes%flux_net(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_net". Message: ', & + alloc_errmsg + return + end if + if (do_direct_local) then + allocate(fluxes%fluxes%flux_dn_dir(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_dn_dir". Message: ', & + alloc_errmsg + return + end if + end if + + ! Fluxes by band always needed for SW. Only allocate for LW + ! when spectralflux is true. + if (nbands == nswbands .or. spectralflux) then + allocate(fluxes%fluxes%bnd_flux_up(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_up". Message: ', & + alloc_errmsg + return + end if + allocate(fluxes%fluxes%bnd_flux_dn(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_dn". Message: ', & + alloc_errmsg + return + end if + allocate(fluxes%fluxes%bnd_flux_net(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) + if (errflg /= 0) then + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_net". Message: ', & + alloc_errmsg + return + end if + if (do_direct_local) then + allocate(fluxes%fluxes%bnd_flux_dn_dir(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_net". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_dn_dir". Message: ', & alloc_errmsg return end if - if (do_direct_local) then - allocate(fluxes%bnd_flux_dn_dir(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_dn_dir". Message: ', & - alloc_errmsg - return - end if - end if end if - end select + end if ! Initialize - call reset_fluxes(fluxes) + call reset_fluxes_byband(fluxes) -end subroutine initialize_rrtmgp_fluxes +end subroutine initialize_rrtmgp_fluxes_byband !========================================================================================= -subroutine reset_fluxes(fluxes) +subroutine reset_fluxes_broadband(fluxes) ! Reset flux arrays to zero. - class(ty_fluxes_broadband), intent(inout) :: fluxes + class(ty_fluxes_broadband_ccpp), intent(inout) :: fluxes !---------------------------------------------------------------------------- ! Reset broadband fluxes - fluxes%flux_up(:,:) = 0._kind_phys - fluxes%flux_dn(:,:) = 0._kind_phys - fluxes%flux_net(:,:) = 0._kind_phys - if (associated(fluxes%flux_dn_dir)) fluxes%flux_dn_dir(:,:) = 0._kind_phys - - select type (fluxes) - type is (ty_fluxes_byband) - ! Reset band-by-band fluxes - if (associated(fluxes%bnd_flux_up)) fluxes%bnd_flux_up(:,:,:) = 0._kind_phys - if (associated(fluxes%bnd_flux_dn)) fluxes%bnd_flux_dn(:,:,:) = 0._kind_phys - if (associated(fluxes%bnd_flux_net)) fluxes%bnd_flux_net(:,:,:) = 0._kind_phys - if (associated(fluxes%bnd_flux_dn_dir)) fluxes%bnd_flux_dn_dir(:,:,:) = 0._kind_phys - end select + fluxes%fluxes%flux_up(:,:) = 0._kind_phys + fluxes%fluxes%flux_dn(:,:) = 0._kind_phys + fluxes%fluxes%flux_net(:,:) = 0._kind_phys + if (associated(fluxes%fluxes%flux_dn_dir)) fluxes%fluxes%flux_dn_dir(:,:) = 0._kind_phys + +end subroutine reset_fluxes_broadband + +!========================================================================================= + +subroutine reset_fluxes_byband(fluxes) -end subroutine reset_fluxes + ! Reset flux arrays to zero. + + class(ty_fluxes_byband_ccpp), intent(inout) :: fluxes + !---------------------------------------------------------------------------- + + ! Reset broadband fluxes + fluxes%fluxes%flux_up(:,:) = 0._kind_phys + fluxes%fluxes%flux_dn(:,:) = 0._kind_phys + fluxes%fluxes%flux_net(:,:) = 0._kind_phys + if (associated(fluxes%fluxes%flux_dn_dir)) fluxes%fluxes%flux_dn_dir(:,:) = 0._kind_phys + + ! Reset band-by-band fluxes + if (associated(fluxes%fluxes%bnd_flux_up)) fluxes%fluxes%bnd_flux_up(:,:,:) = 0._kind_phys + if (associated(fluxes%fluxes%bnd_flux_dn)) fluxes%fluxes%bnd_flux_dn(:,:,:) = 0._kind_phys + if (associated(fluxes%fluxes%bnd_flux_net)) fluxes%fluxes%bnd_flux_net(:,:,:) = 0._kind_phys + if (associated(fluxes%fluxes%bnd_flux_dn_dir)) fluxes%fluxes%bnd_flux_dn_dir(:,:,:) = 0._kind_phys + +end subroutine reset_fluxes_byband !========================================================================================= From 3b106810d7d87210c7dcf530dd86d4e3dadb1d12 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Mon, 31 Mar 2025 15:49:18 -0600 Subject: [PATCH 07/17] finish object wrappers; answers now match again --- src/physics/rrtmgp/ccpp_fluxes.F90 | 5 -- src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 | 3 +- src/physics/rrtmgp/ccpp_optical_props.F90 | 11 ++-- src/physics/rrtmgp/radiation.F90 | 22 ++++---- src/physics/rrtmgp/rrtmgp_inputs.F90 | 34 +++++------ src/physics/rrtmgp/rrtmgp_inputs_cam.F90 | 56 +++++++++---------- src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 | 2 +- src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 | 14 ++--- .../rrtmgp/rrtmgp_lw_gas_optics_data.F90 | 2 +- src/physics/rrtmgp/rrtmgp_lw_main.F90 | 32 +++++------ .../rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 | 8 +-- src/physics/rrtmgp/rrtmgp_post.F90 | 34 +++++------ src/physics/rrtmgp/rrtmgp_pre.F90 | 24 ++++---- 13 files changed, 119 insertions(+), 128 deletions(-) diff --git a/src/physics/rrtmgp/ccpp_fluxes.F90 b/src/physics/rrtmgp/ccpp_fluxes.F90 index 5ec4a2b840..d1ab0e3cb3 100644 --- a/src/physics/rrtmgp/ccpp_fluxes.F90 +++ b/src/physics/rrtmgp/ccpp_fluxes.F90 @@ -3,11 +3,6 @@ module ccpp_fluxes use mo_fluxes, only: ty_fluxes use mo_fluxes, only: ty_fluxes_broadband - !> \section arg_table_ty_fluxes_ccpp Argument Table - !! \htmlinclude ty_fluxes_ccpp.html -! type, public, aibstract, extends(ty_fluxes) :: ty_fluxes_ccpp -! end type - !> \section arg_table_ty_fluxes_broadband_ccpp Argument Table !! \htmlinclude ty_fluxes_broadband_ccpp.html type, public :: ty_fluxes_broadband_ccpp diff --git a/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 b/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 index c1ae872a0f..158da74835 100644 --- a/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 +++ b/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 @@ -4,7 +4,8 @@ module ccpp_gas_optics_rrtmgp !> \section arg_table_ty_gas_optics_rrtmgp_ccpp Argument Table !! \htmlinclude ty_gas_optics_rrtmgp_ccpp.html - type, public, extends(ty_gas_optics_rrtmgp) :: ty_gas_optics_rrtmgp_ccpp + type, public :: ty_gas_optics_rrtmgp_ccpp + type(ty_gas_optics_rrtmgp) :: gas_props end type end module ccpp_gas_optics_rrtmgp diff --git a/src/physics/rrtmgp/ccpp_optical_props.F90 b/src/physics/rrtmgp/ccpp_optical_props.F90 index 57c57a67e3..94615e1375 100644 --- a/src/physics/rrtmgp/ccpp_optical_props.F90 +++ b/src/physics/rrtmgp/ccpp_optical_props.F90 @@ -6,17 +6,14 @@ module ccpp_optical_props !> \section arg_table_ty_optical_props_1scl_ccpp Argument Table !! \htmlinclude ty_optical_props_1scl_ccpp.html - type, public, extends(ty_optical_props_1scl) :: ty_optical_props_1scl_ccpp + type, public :: ty_optical_props_1scl_ccpp + type(ty_optical_props_1scl) :: optical_props end type !> \section arg_table_ty_optical_props_2str_ccpp Argument Table !! \htmlinclude ty_optical_props_2str_ccpp.html - type, public, extends(ty_optical_props_2str) :: ty_optical_props_2str_ccpp - end type - - !> \section arg_table_ty_optical_props_arry_ccpp Argument Table - !! \htmlinclude ty_optical_props_arry_ccpp.html - type, public, abstract, extends(ty_optical_props_arry) :: ty_optical_props_arry_ccpp + type, public :: ty_optical_props_2str_ccpp + type(ty_optical_props_2str) :: optical_props end type end module ccpp_optical_props diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 7baf39b6c9..09660b1a75 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1142,10 +1142,10 @@ subroutine radiation_tend( & ! 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%gas_concs, atm_optics_sw, & + errmsg = kdist_sw%gas_props%gas_optics( & + pmid_day, pint_day, t_day, gas_concs_sw%gas_concs, atm_optics_sw%optical_props, & toa_flux) - call stop_on_err(errmsg, sub, 'kdist_sw%gas_optics') + call stop_on_err(errmsg, sub, 'kdist_sw%gas_props%gas_optics') ! Scale the solar source call get_variability(toa_flux, sfac, band2gpt_sw, nswbands) @@ -1162,22 +1162,22 @@ subroutine radiation_tend( & if (nday > 0) then ! Increment the gas optics (in atm_optics_sw) by the aerosol optics in aer_sw. - errmsg = aer_sw%increment(atm_optics_sw) - call stop_on_err(errmsg, sub, 'aer_sw%increment') + errmsg = aer_sw%optical_props%increment(atm_optics_sw%optical_props) + call stop_on_err(errmsg, sub, 'aer_sw%optical_props%increment') ! Compute clear-sky fluxes. errmsg = rte_sw(& - atm_optics_sw, top_at_1, coszrs_day, toa_flux, & + atm_optics_sw%optical_props, top_at_1, coszrs_day, toa_flux, & alb_dir, alb_dif, fswc%fluxes) 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) - call stop_on_err(errmsg, sub, 'cloud_sw%increment') + errmsg = cloud_sw%optical_props%increment(atm_optics_sw%optical_props) + call stop_on_err(errmsg, sub, 'cloud_sw%optical_props%increment') ! Compute all-sky fluxes. errmsg = rte_sw(& - atm_optics_sw, top_at_1, coszrs_day, toa_flux, & + atm_optics_sw%optical_props, top_at_1, coszrs_day, toa_flux, & alb_dir, alb_dif, fsw%fluxes) call stop_on_err(errmsg, sub, 'all-sky rte_sw') @@ -2233,7 +2233,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) call endrun(sub//': ERROR message: '//errmsg) end if else if (allocated(solar_src_quiet)) then - error_msg = kdist%load( & + error_msg = kdist%gas_props%load( & available_gases%gas_concs, gas_names, key_species, & band2gpt, band_lims_wavenum, & press_ref, press_ref_trop, temp_ref, & @@ -2256,7 +2256,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) error_msg = 'must supply either totplnk and planck_frac, or solar_src_[*]' end if - call stop_on_err(error_msg, sub, 'kdist%load') + call stop_on_err(error_msg, sub, 'kdist%gas_props%load') deallocate( & gas_names, key_species, & diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index a3129265d0..5cdcd259fd 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -269,7 +269,7 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & pmid_rad(:,1) = pint_rad(:,1) + 0.5_kind_phys * (pint_rad(:,2) - pint_rad(:,1)) ! For case of CAM MT, also ensure pint_rad(:,2) > pint_rad(:,1) & pmid_rad(:,2) > max(pmid_rad(:,1), min_pressure) - where (pmid_rad(:,2) <= kdist_sw%get_press_min()) pmid_rad(:,2) = pint_rad(:,2) + 0.01_kind_phys + where (pmid_rad(:,2) <= kdist_sw%gas_props%get_press_min()) pmid_rad(:,2) = pint_rad(:,2) + 0.01_kind_phys 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 @@ -280,8 +280,8 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & end if ! Limit temperatures to be within the limits of RRTMGP validity. - tref_min = kdist_sw%get_temp_min() - tref_max = kdist_sw%get_temp_max() + tref_min = kdist_sw%gas_props%get_temp_min() + tref_max = kdist_sw%gas_props%get_temp_max() t_rad = merge(t_rad, tref_min, t_rad > tref_min) t_rad = merge(t_rad, tref_max, t_rad < tref_max) @@ -382,7 +382,7 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & ! 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) + errmsg = atm_optics_sw%optical_props%alloc_2str(nday, nlay, kdist_sw%gas_props) if (len_trim(errmsg) > 0) then errflg = 1 return @@ -390,7 +390,7 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & ! 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()) + errmsg = aer_sw%optical_props%alloc_2str(nday, nlay, kdist_sw%gas_props%get_band_lims_wavenumber()) if (len_trim(errmsg) > 0) then errflg = 1 return @@ -406,21 +406,21 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & end if ! Initialize object for combined gas + aerosol + cloud optics. - errmsg = atm_optics_lw%alloc_1scl(ncol, nlay, kdist_lw) + errmsg = atm_optics_lw%optical_props%alloc_1scl(ncol, nlay, kdist_lw%gas_props) if (len_trim(errmsg) > 0) then errflg = 1 return end if ! Initialize object for LW aerosol optics. - errmsg = aer_lw%alloc_1scl(ncol, nlay, kdist_lw%get_band_lims_wavenumber()) + errmsg = aer_lw%optical_props%alloc_1scl(ncol, nlay, kdist_lw%gas_props%get_band_lims_wavenumber()) if (len_trim(errmsg) > 0) then errflg = 1 return end if ! Initialize object for Planck sources. - errmsg = sources_lw%sources%alloc(ncol, nlay, kdist_lw) + errmsg = sources_lw%sources%alloc(ncol, nlay, kdist_lw%gas_props) if (len_trim(errmsg) > 0) then errflg = 1 return @@ -475,21 +475,21 @@ subroutine set_wavenumber_bands(kdist_sw, kdist_lw, nswbands, nlwbands, idx_sw_d errflg = 0 errmsg = '' ! Check that number of sw/lw bands in gas optics files matches the parameters. - if (kdist_sw%get_nband() /= nswbands) then - write(errmsg,'(a, a,i4,a,i4)') sub, ': ERROR: number of sw bands in file, ', kdist_sw%get_nband(), & + if (kdist_sw%gas_props%get_nband() /= nswbands) then + write(errmsg,'(a, a,i4,a,i4)') sub, ': ERROR: number of sw bands in file, ', kdist_sw%gas_props%get_nband(), & ", doesn't match parameter nswbands= ", nswbands errflg = 1 return end if - if (kdist_lw%get_nband() /= nlwbands) then - write(errmsg,'(a, a,i4,a,i4)') sub, ': ERROR: number of lw bands in file, ', kdist_lw%get_nband(), & + if (kdist_lw%gas_props%get_nband() /= nlwbands) then + write(errmsg,'(a, a,i4,a,i4)') sub, ': ERROR: number of lw bands in file, ', kdist_lw%gas_props%get_nband(), & ", doesn't match parameter nlwbands= ", nlwbands errflg = 1 return end if - nswgpts = kdist_sw%get_ngpt() - nlwgpts = kdist_lw%get_ngpt() + nswgpts = kdist_sw%gas_props%get_ngpt() + nlwgpts = kdist_lw%gas_props%get_ngpt() ! SW band bounds in cm^-1 allocate( values(2,nswbands), stat=istat ) @@ -498,12 +498,12 @@ subroutine set_wavenumber_bands(kdist_sw, kdist_lw, nswbands, nlwbands, idx_sw_d errflg = 1 return end if - values = kdist_sw%get_band_lims_wavenumber() + values = kdist_sw%gas_props%get_band_lims_wavenumber() wavenumber_low_shortwave = values(1,:) wavenumber_high_shortwave = values(2,:) ! First and last g-point for each SW band: - band2gpt_sw = kdist_sw%get_band_lims_gpoint() + band2gpt_sw = kdist_sw%gas_props%get_band_lims_gpoint() ! Indices into specific bands call get_band_index_by_value('sw', 500.0_kind_phys, 'nm', nswbands, & @@ -536,7 +536,7 @@ subroutine set_wavenumber_bands(kdist_sw, kdist_lw, nswbands, nlwbands, idx_sw_d errflg = 1 return end if - values = kdist_lw%get_band_lims_wavenumber() + values = kdist_lw%gas_props%get_band_lims_wavenumber() wavenumber_low_longwave = values(1,:) wavenumber_high_longwave = values(2,:) diff --git a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 index 849e072f47..d4e99a544f 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 @@ -551,39 +551,39 @@ subroutine rrtmgp_set_cloud_sw( & ! MCICA uses spectral data (on bands) to construct subcolumns (one per g-point) call mcica_subcol_sw( & - kdist_sw, nswbands, nswgpts, nday, nlay, & + kdist_sw%gas_props, 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) + errmsg = cloud_sw%optical_props%alloc_2str(nday, nlay, kdist_sw%gas_props) if (len_trim(errmsg) > 0) then - call endrun(trim(sub)//': ERROR: cloud_sw%alloc_2str: '//trim(errmsg)) + call endrun(trim(sub)//': ERROR: cloud_sw%optical_props%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 + cloud_sw%optical_props%tau = 0.0_r8 + cloud_sw%optical_props%ssa = 1.0_r8 + cloud_sw%optical_props%g = 0.0_r8 ! Set the properties on g-points. do igpt = 1,nswgpts - cloud_sw%g (:,ktoprad:,igpt) = asmcmcl(igpt,:,:) - cloud_sw%ssa(:,ktoprad:,igpt) = ssacmcl(igpt,:,:) - cloud_sw%tau(:,ktoprad:,igpt) = taucmcl(igpt,:,:) + cloud_sw%optical_props%g (:,ktoprad:,igpt) = asmcmcl(igpt,:,:) + cloud_sw%optical_props%ssa(:,ktoprad:,igpt) = ssacmcl(igpt,:,:) + cloud_sw%optical_props%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]. - errmsg = cloud_sw%validate() + errmsg = cloud_sw%optical_props%validate() if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: cloud_sw%validate: '//trim(errmsg)) + call endrun(sub//': ERROR: cloud_sw%optical_props%validate: '//trim(errmsg)) end if ! delta scaling adjusts for forward scattering - errmsg = cloud_sw%delta_scale() + errmsg = cloud_sw%optical_props%delta_scale() if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: cloud_sw%delta_scale: '//trim(errmsg)) + call endrun(sub//': ERROR: cloud_sw%optical_props%delta_scale: '//trim(errmsg)) end if ! All information is in cloud_sw, now deallocate local vars. @@ -626,13 +626,13 @@ subroutine rrtmgp_set_aer_lw(icall, state, pbuf, 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%optical_props%tau = 0.0_r8 - aer_lw%tau(:ncol, ktoprad:, :) = aer_lw_abs(:ncol, ktopcam:, :) + aer_lw%optical_props%tau(:ncol, ktoprad:, :) = aer_lw_abs(:ncol, ktopcam:, :) - errmsg = aer_lw%validate() + errmsg = aer_lw%optical_props%validate() if (len_trim(errmsg) > 0) then - call endrun(sub//': ERROR: aer_lw%validate: '//trim(errmsg)) + call endrun(sub//': ERROR: aer_lw%optical_props%validate: '//trim(errmsg)) end if end subroutine rrtmgp_set_aer_lw @@ -688,31 +688,31 @@ subroutine rrtmgp_set_aer_sw( & ! 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 + aer_sw%optical_props%tau = 0.0_r8 + aer_sw%optical_props%ssa = 1.0_r8 + aer_sw%optical_props%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%optical_props%tau = aer_tau + ! aer_sw%optical_props%ssa = aer_tau_w / aer_tau + ! aer_sw%optical_props%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) + aer_sw%optical_props%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:,:), & + aer_sw%optical_props%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:,:), & + aer_sw%optical_props%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) + aer_sw%optical_props%ssa = min(max(aer_sw%optical_props%ssa, 0._r8), 1._r8) + aer_sw%optical_props%g = min(max(aer_sw%optical_props%g, -1._r8), 1._r8) end if diff --git a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 index 0cb7c739c7..c65c2e3243 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 @@ -242,7 +242,7 @@ subroutine rrtmgp_lw_cloud_optics_run(ncol, nlay, nlaycam, cld, cldfsnow, cldfgr ! Enforce tauc >= 0. tauc = merge(tauc, 0.0_kind_phys, tauc > 0.0_kind_phys) - errmsg =cloud_lw%alloc_1scl(ncol, nlay, kdist_lw) + errmsg =cloud_lw%optical_props%alloc_1scl(ncol, nlay, kdist_lw%gas_props) if (len_trim(errmsg) > 0) then errflg = 1 return diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 index da5fe9df03..87c270b417 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 @@ -32,11 +32,11 @@ subroutine rrtmgp_lw_gas_optics_run(dolw, iter_num, ncol, rrtmgp_phys_blksz, p_l real(kind_phys), dimension(:,:), intent(in) :: t_lay real(kind_phys), dimension(:), intent(in) :: tsfg real(kind_phys), dimension(:,:), intent(in) :: t_lev - class(ty_gas_concs_ccpp), intent(in) :: gas_concs !< RRTMGP gas concentrations object + type(ty_gas_concs_ccpp), intent(in) :: gas_concs !< RRTMGP gas concentrations object ! Outputs - class(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clrsky !< Clearsky optical properties - class(ty_source_func_lw_ccpp), intent(inout) :: sources + type(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clrsky !< Clearsky optical properties + type(ty_source_func_lw_ccpp), intent(inout) :: sources character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg type(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: lw_gas_props !< RRTMGP gas optics object @@ -55,23 +55,23 @@ subroutine rrtmgp_lw_gas_optics_run(dolw, iter_num, ncol, rrtmgp_phys_blksz, p_l iCol = ((iter_num - 1) * rrtmgp_phys_blksz) + 1 iCol2= min(iCol + rrtmgp_phys_blksz - 1, ncol) if (include_interface_temp) then - call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_optics(& + call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_props%gas_optics(& p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) gas_concs%gas_concs, & ! IN - RRTMGP DDT: trace gas volume mixing-ratios - lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties + lw_optical_props_clrsky%optical_props, & ! OUT - RRTMGP DDT: longwave optical properties sources%sources, & ! OUT - RRTMGP DDT: source functions tlev=t_lev(iCol:iCol2,:))) ! IN - Temperature @ layer-interfaces (K) (optional) else - call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_optics(& + call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_props%gas_optics(& p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) gas_concs%gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties + lw_optical_props_clrsky%optical_props, & ! OUT - RRTMGP DDT: longwave optical properties sources%sources)) ! OUT - RRTMGP DDT: source functions end if diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 index 54f3904fb1..a2a27195fe 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 @@ -71,7 +71,7 @@ subroutine rrtmgp_lw_gas_optics_data_init(kdist, available_gases, gas_names, errflg = 0 ! Initialize the gas optics object with data. - errmsg = kdist%load( & + errmsg = kdist%gas_props%load( & available_gases%gas_concs, gas_names, key_species, & band2gpt, band_lims_wavenum, & press_ref, press_ref_trop, temp_ref, & diff --git a/src/physics/rrtmgp/rrtmgp_lw_main.F90 b/src/physics/rrtmgp/rrtmgp_lw_main.F90 index b889447c6f..da7cfdd102 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_main.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_main.F90 @@ -6,7 +6,6 @@ module rrtmgp_lw_main use machine, only: kind_phys use mo_rte_lw, only: rte_lw use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp - use ccpp_optical_props, only: ty_optical_props_arry_ccpp use ccpp_optical_props, only: ty_optical_props_1scl_ccpp use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp use ccpp_fluxes, only: ty_fluxes_broadband_ccpp @@ -43,7 +42,6 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, real(kind_phys), dimension(:,:), intent(in) :: sfc_emiss_byband class(ty_source_func_lw_ccpp), intent(in) :: sources - !class(ty_source_func_lw), intent(in) :: sources ! Outputs real(kind_phys), dimension(:,:), intent(inout) :: fluxlwUP_jac @@ -77,13 +75,13 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, ! ################################################################################### ! Increment call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky',& - aerlw%increment(lw_optical_props_clrsky)) + aerlw%optical_props%increment(lw_optical_props_clrsky%optical_props)) ! Call RTE solver if (doLWclrsky) then if (nGauss_angles .gt. 1) then call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band @@ -92,9 +90,9 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, else if (use_lw_optimal_angles) then call check_error_msg('rrtmgp_lw_main_opt_angle',& - lw_gas_props%compute_optimal_angles(lw_optical_props_clrsky,lw_Ds)) + lw_gas_props%gas_props%compute_optimal_angles(lw_optical_props_clrsky%optical_props,lw_Ds)) call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band @@ -102,7 +100,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, lw_Ds = lw_Ds)) else call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band @@ -130,13 +128,13 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, if (doGP_lwscat) then ! Increment call check_error_msg('rrtmgp_lw_main_increment_clrsky_to_clouds',& - lw_optical_props_clrsky%increment(lw_optical_props_clouds)) + lw_optical_props_clrsky%optical_props%increment(lw_optical_props_clouds%optical_props)) if (use_LW_jacobian) then if (nGauss_angles .gt. 1) then ! Compute LW Jacobians; use Gaussian angles call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & - lw_optical_props_clouds, & ! IN - optical-properties + lw_optical_props_clouds%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band @@ -146,7 +144,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, else ! Compute LW Jacobians; don't use Gaussian angles call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & - lw_optical_props_clouds, & ! IN - optical-properties + lw_optical_props_clouds%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band @@ -158,7 +156,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, ! Compute LW Jacobians; use Gaussian angles ! Don't compute LW Jacobians; use Gaussian angles call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & - lw_optical_props_clouds, & ! IN - optical-properties + lw_optical_props_clouds%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band @@ -167,7 +165,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, else ! Don't compute LW Jacobians; don't use Gaussian angles call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & - lw_optical_props_clouds, & ! IN - optical-properties + lw_optical_props_clouds%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band @@ -178,13 +176,13 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, else ! Increment call check_error_msg('rrtmgp_lw_main_increment_clouds_to_clrsky', & - lw_optical_props_clouds%increment(lw_optical_props_clrsky)) + lw_optical_props_clouds%optical_props%increment(lw_optical_props_clrsky%optical_props)) if (use_LW_jacobian) then if (nGauss_angles .gt. 1) then ! Compute LW Jacobians; use Gaussian angles call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band @@ -194,7 +192,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, else ! Compute LW Jacobians; don't use Gaussian angles call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band @@ -205,7 +203,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, if (nGauss_angles .gt. 1) then ! Don't compute LW Jacobians; use Gaussian angles call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band @@ -214,7 +212,7 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, else ! Don't compute LW Jacobians; don't use Gaussian angles call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky, & ! IN - optical-properties + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties top_at_1, & ! IN - veritcal ordering flag sources%sources, & ! IN - source function sfc_emiss_byband, & ! IN - surface emissivity in each LW band diff --git a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 index b7f8657d70..040337ce7f 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 @@ -155,7 +155,7 @@ subroutine rrtmgp_lw_mcica_subcol_gen_run( & do idx = 1,ncol do isubcol = 1,ngpt if (iscloudy(isubcol,idx,kdx) .and. (cldf(idx,kdx) > 0._kind_phys) ) then - ndx = kdist%convert_gpt2band(isubcol) + ndx = kdist%gas_props%convert_gpt2band(isubcol) taucmcl(isubcol,idx,kdx) = tauc(ndx,idx,kdx) else taucmcl(isubcol,idx,kdx) = 0._kind_phys @@ -168,15 +168,15 @@ subroutine rrtmgp_lw_mcica_subcol_gen_run( & ! If there is an extra layer in the radiation then this initialization ! will provide zero optical depths there - cloud_lw%tau = 0.0_kind_phys + cloud_lw%optical_props%tau = 0.0_kind_phys ! Set the properties on g-points do idx = 1, ngpt - cloud_lw%tau(:,ktoprad:,idx) = taucmcl(idx,:,:) + cloud_lw%optical_props%tau(:,ktoprad:,idx) = taucmcl(idx,:,:) end do ! validate checks that: tau > 0 - errmsg = cloud_lw%validate() + errmsg = cloud_lw%optical_props%validate() if (len_trim(errmsg) > 0) then errflg = 1 return diff --git a/src/physics/rrtmgp/rrtmgp_post.F90 b/src/physics/rrtmgp/rrtmgp_post.F90 index ccf661ccc8..ed3c802a9e 100644 --- a/src/physics/rrtmgp/rrtmgp_post.F90 +++ b/src/physics/rrtmgp/rrtmgp_post.F90 @@ -18,15 +18,15 @@ subroutine rrtmgp_post_run(ncol, qrs, qrl, pdel, atm_optics_sw, cloud_sw, aer_sw real(kind_phys), dimension(:,:), intent(in) :: pdel real(kind_phys), dimension(:,:), intent(inout) :: qrs real(kind_phys), dimension(:,:), intent(inout) :: qrl - class(ty_optical_props_2str_ccpp), intent(inout) :: atm_optics_sw - class(ty_optical_props_1scl_ccpp), intent(inout) :: aer_lw - class(ty_optical_props_2str_ccpp), intent(inout) :: aer_sw - class(ty_optical_props_1scl_ccpp), intent(inout) :: cloud_lw - class(ty_optical_props_2str_ccpp), intent(inout) :: cloud_sw - class(ty_fluxes_broadband_ccpp), intent(inout) :: fswc - class(ty_fluxes_broadband_ccpp), intent(inout) :: flwc - class(ty_fluxes_byband_ccpp), intent(inout) :: fsw - class(ty_fluxes_byband_ccpp), intent(inout) :: flw + type(ty_optical_props_2str_ccpp), intent(inout) :: atm_optics_sw + type(ty_optical_props_1scl_ccpp), intent(inout) :: aer_lw + type(ty_optical_props_2str_ccpp), intent(inout) :: aer_sw + type(ty_optical_props_1scl_ccpp), intent(inout) :: cloud_lw + type(ty_optical_props_2str_ccpp), intent(inout) :: cloud_sw + type(ty_fluxes_broadband_ccpp), intent(inout) :: fswc + type(ty_fluxes_broadband_ccpp), intent(inout) :: flwc + type(ty_fluxes_byband_ccpp), intent(inout) :: fsw + type(ty_fluxes_byband_ccpp), intent(inout) :: flw type(ty_source_func_lw_ccpp), intent(inout) :: sources_lw character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -56,12 +56,12 @@ end subroutine rrtmgp_post_run subroutine free_optics_sw(optics) - class(ty_optical_props_2str_ccpp), intent(inout) :: optics + type(ty_optical_props_2str_ccpp), 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() + if (allocated(optics%optical_props%tau)) deallocate(optics%optical_props%tau) + if (allocated(optics%optical_props%ssa)) deallocate(optics%optical_props%ssa) + if (allocated(optics%optical_props%g)) deallocate(optics%optical_props%g) + call optics%optical_props%finalize() end subroutine free_optics_sw @@ -69,10 +69,10 @@ end subroutine free_optics_sw subroutine free_optics_lw(optics) - class(ty_optical_props_1scl_ccpp), intent(inout) :: optics + type(ty_optical_props_1scl_ccpp), intent(inout) :: optics - if (allocated(optics%tau)) deallocate(optics%tau) - call optics%finalize() + if (allocated(optics%optical_props%tau)) deallocate(optics%optical_props%tau) + call optics%optical_props%finalize() end subroutine free_optics_lw diff --git a/src/physics/rrtmgp/rrtmgp_pre.F90 b/src/physics/rrtmgp/rrtmgp_pre.F90 index 0918350eeb..8c72d0b6fa 100644 --- a/src/physics/rrtmgp/rrtmgp_pre.F90 +++ b/src/physics/rrtmgp/rrtmgp_pre.F90 @@ -190,26 +190,26 @@ subroutine initialize_rrtmgp_fluxes_broadband(ncol, nlevels, nbands, nswbands, s ! Broadband fluxes allocate(fluxes%fluxes%flux_up(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_up". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_up". Message: ', & alloc_errmsg return end if allocate(fluxes%fluxes%flux_dn(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_dn". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_dn". Message: ', & alloc_errmsg return end if allocate(fluxes%fluxes%flux_net(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_net". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_net". Message: ', & alloc_errmsg return end if if (do_direct_local) then allocate(fluxes%fluxes%flux_dn_dir(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_dn_dir". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_dn_dir". Message: ', & alloc_errmsg return end if @@ -249,26 +249,26 @@ subroutine initialize_rrtmgp_fluxes_byband(ncol, nlevels, nbands, nswbands, spec ! Broadband fluxes allocate(fluxes%fluxes%flux_up(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_up". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_up". Message: ', & alloc_errmsg return end if allocate(fluxes%fluxes%flux_dn(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_dn". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_dn". Message: ', & alloc_errmsg return end if allocate(fluxes%fluxes%flux_net(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_net". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_net". Message: ', & alloc_errmsg return end if if (do_direct_local) then allocate(fluxes%fluxes%flux_dn_dir(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%flux_dn_dir". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_dn_dir". Message: ', & alloc_errmsg return end if @@ -279,26 +279,26 @@ subroutine initialize_rrtmgp_fluxes_byband(ncol, nlevels, nbands, nswbands, spec if (nbands == nswbands .or. spectralflux) then allocate(fluxes%fluxes%bnd_flux_up(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_up". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%bnd_flux_up". Message: ', & alloc_errmsg return end if allocate(fluxes%fluxes%bnd_flux_dn(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_dn". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%bnd_flux_dn". Message: ', & alloc_errmsg return end if allocate(fluxes%fluxes%bnd_flux_net(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_net". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%bnd_flux_net". Message: ', & alloc_errmsg return end if if (do_direct_local) then allocate(fluxes%fluxes%bnd_flux_dn_dir(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%bnd_flux_dn_dir". Message: ', & + write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%bnd_flux_dn_dir". Message: ', & alloc_errmsg return end if From 256326fbdfcddeebeedb25375c2dd5ec2ec10683 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Mon, 31 Mar 2025 16:15:00 -0600 Subject: [PATCH 08/17] remove duplicate code; add in fix from cam_development --- src/physics/rrtmgp/mcica_subcol_gen.F90 | 116 +----------------- src/physics/rrtmgp/radiation.F90 | 6 +- src/physics/rrtmgp/rrtmgp_inputs_cam.F90 | 2 +- .../rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 | 2 +- src/physics/rrtmgp/rrtmgp_post.F90 | 10 +- 5 files changed, 13 insertions(+), 123 deletions(-) diff --git a/src/physics/rrtmgp/mcica_subcol_gen.F90 b/src/physics/rrtmgp/mcica_subcol_gen.F90 index 85bea8281c..ab1a2cf71f 100644 --- a/src/physics/rrtmgp/mcica_subcol_gen.F90 +++ b/src/physics/rrtmgp/mcica_subcol_gen.F90 @@ -36,126 +36,12 @@ module mcica_subcol_gen private save -public :: mcica_subcol_lw, mcica_subcol_sw +public :: mcica_subcol_sw !======================================================================================== contains !======================================================================================== -subroutine mcica_subcol_lw( & - 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 - ! 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_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) :: 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(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 variables - - 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,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,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, 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) ) - 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) - 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, & diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 09660b1a75..7d056d1642 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1371,8 +1371,8 @@ subroutine radiation_tend( & deallocate(rd) end if - call rrtmgp_post_run(ncol, qrs, qrl, state%pdel, atm_optics_sw, cloud_sw, aer_sw, & - fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, errmsg, errflg) + call rrtmgp_post_run(ncol, qrs, qrl, fsns, state%pdel, atm_optics_sw, cloud_sw, aer_sw, & + fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, cam_out%netsw, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if @@ -1438,8 +1438,6 @@ subroutine set_sw_diags() 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) - ! 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) diff --git a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 index d4e99a544f..4c65ffbb69 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 @@ -26,7 +26,7 @@ module rrtmgp_inputs_cam 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 mcica_subcol_gen, only: mcica_subcol_sw use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw diff --git a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 index 040337ce7f..b243a46300 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 @@ -81,7 +81,7 @@ subroutine rrtmgp_lw_mcica_subcol_gen_run( & integer :: idx, isubcol, kdx, ndx real(kind_phys), parameter :: cldmin = 1.0e-80_kind_phys ! min cloud fraction - real(kind_phys) :: cldf(ncol,pver) ! cloud fraction clipped to cldmin + real(kind_phys) :: cldf(ncol,nver) ! cloud fraction clipped to cldmin type(ShrKissRandGen) :: kiss_gen ! KISS RNG object integer :: kiss_seed(ncol,4) diff --git a/src/physics/rrtmgp/rrtmgp_post.F90 b/src/physics/rrtmgp/rrtmgp_post.F90 index ed3c802a9e..e943f851a2 100644 --- a/src/physics/rrtmgp/rrtmgp_post.F90 +++ b/src/physics/rrtmgp/rrtmgp_post.F90 @@ -12,10 +12,11 @@ module rrtmgp_post !> \section arg_table_rrtmgp_post_run Argument Table !! \htmlinclude rrtmgp_post_run.html !! -subroutine rrtmgp_post_run(ncol, qrs, qrl, pdel, atm_optics_sw, cloud_sw, aer_sw, & - fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, errmsg, errflg) +subroutine rrtmgp_post_run(ncol, qrs, qrl, fsns, pdel, atm_optics_sw, cloud_sw, aer_sw, & + fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, netsw, errmsg, errflg) integer, intent(in) :: ncol real(kind_phys), dimension(:,:), intent(in) :: pdel + real(kind_phys), dimension(:), intent(in) :: fsns real(kind_phys), dimension(:,:), intent(inout) :: qrs real(kind_phys), dimension(:,:), intent(inout) :: qrl type(ty_optical_props_2str_ccpp), intent(inout) :: atm_optics_sw @@ -28,6 +29,7 @@ subroutine rrtmgp_post_run(ncol, qrs, qrl, pdel, atm_optics_sw, cloud_sw, aer_sw type(ty_fluxes_byband_ccpp), intent(inout) :: fsw type(ty_fluxes_byband_ccpp), intent(inout) :: flw type(ty_source_func_lw_ccpp), intent(inout) :: sources_lw + real(kind_phys), dimension(:), intent(out) :: netsw character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -38,6 +40,10 @@ subroutine rrtmgp_post_run(ncol, qrs, qrl, pdel, atm_optics_sw, cloud_sw, aer_sw ! as Q*dp (for energy conservation). qrs(:ncol,:) = qrs(:ncol,:) * pdel(:ncol,:) qrl(:ncol,:) = qrl(:ncol,:) * pdel(:ncol,:) + + ! Set the netsw to be sent to the coupler + netsw(:ncol) = fsns(:ncol) + call free_optics_sw(atm_optics_sw) call free_optics_sw(cloud_sw) call free_optics_sw(aer_sw) From d3ffdbddf3e90cde5e837329c05a86836aa4eb07 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Wed, 2 Apr 2025 16:27:24 -0600 Subject: [PATCH 09/17] code clean-up and adding comments --- .../rrtmgp/atmos_phys_string_utils.F90 | 58 ++++ src/physics/rrtmgp/calculate_net_heating.F90 | 18 +- src/physics/rrtmgp/radiation.F90 | 44 +-- src/physics/rrtmgp/radiation_utils.F90 | 53 ++-- .../rrtmgp_dry_static_energy_tendency.F90 | 12 +- src/physics/rrtmgp/rrtmgp_inputs.F90 | 237 +++++++-------- src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 | 100 +++---- src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 | 69 +++-- .../rrtmgp/rrtmgp_lw_gas_optics_data.F90 | 74 ++--- .../rrtmgp/rrtmgp_lw_gas_optics_pre.F90 | 37 +-- src/physics/rrtmgp/rrtmgp_lw_main.F90 | 280 +++++++++++------- .../rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 | 42 +-- src/physics/rrtmgp/rrtmgp_post.F90 | 32 +- src/physics/rrtmgp/rrtmgp_pre.F90 | 85 ++++-- 14 files changed, 653 insertions(+), 488 deletions(-) create mode 100644 src/physics/rrtmgp/atmos_phys_string_utils.F90 diff --git a/src/physics/rrtmgp/atmos_phys_string_utils.F90 b/src/physics/rrtmgp/atmos_phys_string_utils.F90 new file mode 100644 index 0000000000..25be190fd4 --- /dev/null +++ b/src/physics/rrtmgp/atmos_phys_string_utils.F90 @@ -0,0 +1,58 @@ +module atmos_phys_string_utils + ! String utils + + implicit none + private + + public :: to_lower + public :: to_upper + +contains + + pure function to_lower(input_string) result(lowercase_string) + character(len=*), intent(in) :: input_string + character(len=*) :: lowercase_string + ! Local variables + + integer :: i ! Index + integer :: aseq ! ascii collating sequence + integer :: upper_to_lower ! integer to convert case + character(len=1) :: ctmp ! Character temporary + !----------------------------------------------------------------------- + upper_to_lower = iachar("a") - iachar("A") + + do i = 1, len(input_string) + ctmp = input_string(i:i) + aseq = iachar(ctmp) + if ( aseq >= iachar("A") .and. aseq <= iachar("Z") ) & + ctmp = achar(aseq + upper_to_lower) + lowercase_string(i:i) = ctmp + end do + + end function to_lower + +!--------------------------------------------------------------------------- +!--------------------------------------------------------------------------- + + pure function to_upper(input_string) result(uppercase_string) + character(len=*), intent(in) :: input_string + character(len=*) :: uppercase_string + + integer :: i ! Index + integer :: aseq ! ascii collating sequence + integer :: lower_to_upper ! integer to convert case + character(len=1) :: ctmp ! Character temporary + !----------------------------------------------------------------------- + lower_to_upper = iachar("A") - iachar("a") + + do i = 1, len(input_string) + ctmp = input_string(i:i) + aseq = iachar(ctmp) + if ( aseq >= iachar("a") .and. aseq <= iachar("z") ) & + ctmp = achar(aseq + lower_to_upper) + uppercase_string(i:i) = ctmp + end do + + end function to_upper + +end module atmos_phys_string_utils diff --git a/src/physics/rrtmgp/calculate_net_heating.F90 b/src/physics/rrtmgp/calculate_net_heating.F90 index b445ac1d7e..7c39882b4b 100644 --- a/src/physics/rrtmgp/calculate_net_heating.F90 +++ b/src/physics/rrtmgp/calculate_net_heating.F90 @@ -35,16 +35,16 @@ subroutine calculate_net_heating_run(ncol, rad_heat, qrl, qrs, fsns, fsnt, flns, !----------------------------------------------------------------------- ! Arguments - integer, intent(in) :: ncol ! horizontal dimension - real(kind_phys), intent(in) :: qrl(:,:) ! longwave heating - real(kind_phys), intent(in) :: qrs(:,:) ! shortwave heating - real(kind_phys), intent(in) :: fsns(:) ! Surface solar absorbed flux - real(kind_phys), intent(in) :: fsnt(:) ! Net column abs solar flux at model top - real(kind_phys), intent(in) :: flns(:) ! Srf longwave cooling (up-down) flux - real(kind_phys), intent(in) :: flnt(:) ! Net outgoing lw flux at model top + integer, intent(in) :: ncol ! horizontal dimension + real(kind_phys), intent(in) :: qrl(:,:) ! longwave heating [J kg-1 s-1] + real(kind_phys), intent(in) :: qrs(:,:) ! shortwave heating [J kg-1 s-1] + real(kind_phys), intent(in) :: fsns(:) ! Surface solar absorbed flux [W m-2] + real(kind_phys), intent(in) :: fsnt(:) ! Net column abs solar flux at model top [W m-2] + real(kind_phys), intent(in) :: flns(:) ! Srf longwave cooling (up-down) flux [W m-2] + real(kind_phys), intent(in) :: flnt(:) ! Net outgoing lw flux at model top [W m-2] logical, intent(in) :: is_offline_dyn ! is offline dycore - real(kind_phys), intent(out) :: rad_heat(:,:) ! radiative heating - real(kind_phys), intent(out) :: net_flx(:) ! net boundary flux + real(kind_phys), intent(out) :: rad_heat(:,:) ! radiative heating [J kg-1 s-1] + real(kind_phys), intent(out) :: net_flx(:) ! net boundary flux [W m-2] character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 3594057a24..f718314eb4 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -411,7 +411,8 @@ end function radiation_do !================================================================================================ subroutine radiation_init(pbuf2d) - use rrtmgp_inputs, only: rrtmgp_inputs_init + use rrtmgp_pre, only: rrtmgp_pre_init + use rrtmgp_inputs, only: rrtmgp_inputs_init use rrtmgp_inputs_cam, only: rrtmgp_inputs_cam_init ! Initialize the radiation and cloud optics. @@ -444,16 +445,11 @@ subroutine radiation_init(pbuf2d) character(len=*), parameter :: sub = 'radiation_init' !----------------------------------------------------------------------- - ! Create lowercase version of the gaslist for RRTMGP. The ty_gas_concs_ccpp 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 - - ! PEVERWHEE - add this to new rrtmgp_pre_iinit routine (possible also above code?) - errmsg = available_gases%gas_concs%init(gaslist_lc) - call stop_on_err(errmsg, sub, 'available_gases%init') + ! Initialize available_gases object + call rrtmgp_pre_init(nradgas, gaslist, available_gases, gaslist_lc, errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': ERROR -'//errmsg) + end if ! Read RRTMGP coefficients files and initialize kdist objects. call coefs_init(coefs_sw_file, available_gases, kdist_sw) @@ -1236,19 +1232,25 @@ subroutine radiation_tend( & if (degrau_idx > 0) then call pbuf_get_field(pbuf, degrau_idx, degrau) end if + do_graupel = ((icgrauwp_idx > 0) .and. (degrau_idx > 0) .and. associated(cldfgrau)) do_snow = associated(cldfsnow) - ! Set cloud optical properties in cloud_lw object. - call rrtmgp_lw_cloud_optics_run(ncol, nlay, nlaycam, cld, cldfsnow, cldfgrau, & - cldfprime, graupel_in_rad, kdist_lw, cloud_lw, lambda, mu, iclwp, iciwp, & - dei, icswp, des, icgrauwp, degrau, nlwbands, do_snow, & - do_graupel, cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, pver, ktopcam, & - grau_lw_abs_cloudsim, idx_lw_cloudsim, tauc, cldf, errmsg, errflg) + ! 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,:,:) + + ! Set cloud optical properties in cloud_lw object. + call rrtmgp_lw_cloud_optics_run(dolw, ncol, nlay, nlaycam, cld, cldfsnow, cldfgrau, & + cldfprime, graupel_in_rad, kdist_lw, cloud_lw, lambda, mu, iclwp, iciwp, & + dei, icswp, des, icgrauwp, degrau, nlwbands, do_snow, & + do_graupel, pver, ktopcam, tauc, cldf, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if - call rrtmgp_lw_mcica_subcol_gen_run(ktoprad, & + + call rrtmgp_lw_mcica_subcol_gen_run(dolw, ktoprad, & kdist_lw, nlwbands, nlwgpts, ncol, pver, nlaycam, nlwgpts, & state%pmid, cldf, tauc, cloud_lw, errmsg, errflg ) if (errflg /= 0) then @@ -1264,8 +1266,8 @@ subroutine radiation_tend( & call rrtmgp_get_gas_mmrs(icall, state, pbuf, nlay, gas_mmrs) ! Set gas volume mixing ratios for this call in gas_concs_lw - call rrtmgp_lw_gas_optics_pre_run(icall, gas_mmrs, state%pmid, state%pint, nlay, ncol, gaslist, idxday, & - pverp, ktoprad, ktopcam, dolw, nradgas, gas_concs_lw, errmsg, errflg) + call rrtmgp_lw_gas_optics_pre_run(icall, gas_mmrs, state%pmid, state%pint, nlay, ncol, gaslist, & + idxday, pverp, ktoprad, ktopcam, dolw, nradgas, gas_concs_lw, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if @@ -1372,7 +1374,7 @@ subroutine radiation_tend( & end if ! docosp end if ! if (dosw .or. dolw) then - ! Calculate dry static energy if LW calc wasn't done; needed before calling radheat_run + ! Calculate dry static energy if LW calc or SW calc wasn't done; needed before calling radheat_run call rrtmgp_dry_static_energy_tendency_run(ncol, state%pdel, (.not. dosw), (.not. dolw), & qrs, qrl, errmsg, errflg) if (errflg /= 0) then diff --git a/src/physics/rrtmgp/radiation_utils.F90 b/src/physics/rrtmgp/radiation_utils.F90 index 3c9ec24afb..2eeb2ff89b 100644 --- a/src/physics/rrtmgp/radiation_utils.F90 +++ b/src/physics/rrtmgp/radiation_utils.F90 @@ -21,14 +21,15 @@ module radiation_utils subroutine radiation_utils_init(nswbands_in, nlwbands_in, low_shortwave, high_shortwave, & low_longwave, high_longwave, errmsg, errflg) - integer, intent(in) :: nswbands_in - integer, intent(in) :: nlwbands_in - real(kind_phys), intent(in) :: low_shortwave(:) - real(kind_phys), intent(in) :: high_shortwave(:) - real(kind_phys), intent(in) :: low_longwave(:) - real(kind_phys), intent(in) :: high_longwave(:) - integer, intent(out) :: errflg - character(len=*), intent(out) :: errmsg + integer, intent(in) :: nswbands_in ! Number of shortwave bands + integer, intent(in) :: nlwbands_in ! Number of longwave bands + real(kind_phys), intent(in) :: low_shortwave(:) ! Low range values for shortwave bands (cm-1) + real(kind_phys), intent(in) :: high_shortwave(:) ! High range values for shortwave bands (cm-1) + real(kind_phys), intent(in) :: low_longwave(:) ! Low range values for longwave bands (cm-1) + real(kind_phys), intent(in) :: high_longwave(:) ! High range values for longwave bands (cm-1) + integer, intent(out) :: errflg + character(len=*),intent(out) :: errmsg + ! Local variables character(len=256) :: alloc_errmsg errflg = 0 @@ -69,13 +70,13 @@ end subroutine radiation_utils_init subroutine get_sw_spectral_boundaries_ccpp(low_boundaries, high_boundaries, units, errmsg, errflg) - ! provide spectral boundaries of each shortwave band + ! provide spectral boundaries of each shortwave band in the units requested - real(kind_phys), dimension(:), intent(out) :: low_boundaries - real(kind_phys), dimension(:), intent(out) :: high_boundaries - character(*), intent(in) :: units ! requested units - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), dimension(:), intent(out) :: low_boundaries ! low range bounds for shortwave bands in requested units + real(kind_phys), dimension(:), intent(out) :: high_boundaries ! high range bounds for shortwave bands in requested units + character(*), intent(in) :: units ! requested units + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg character(len=*), parameter :: sub = 'get_sw_spectral_boundaries_ccpp' !---------------------------------------------------------------------------- @@ -115,10 +116,11 @@ end subroutine get_sw_spectral_boundaries_ccpp subroutine get_lw_spectral_boundaries_ccpp(low_boundaries, high_boundaries, units, errmsg, errflg) - ! provide spectral boundaries of each longwave band + ! provide spectral boundaries of each longwave band in the units requested - real(kind_phys), intent(out) :: low_boundaries(nlwbands), high_boundaries(nlwbands) - character(*), intent(in) :: units ! requested units + real(kind_phys), intent(out) :: low_boundaries(nlwbands) ! low range bounds for longwave bands in requested units + real(kind_phys), intent(out) :: high_boundaries(nlwbands) ! high range bounds for longwave bands in requested units + character(*), intent(in) :: units ! requested units character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -160,15 +162,16 @@ end subroutine get_lw_spectral_boundaries_ccpp subroutine get_mu_lambda_weights_ccpp(nmu, nlambda, g_mu, g_lambda, lamc, pgam, & mu_wgts, lambda_wgts, errmsg, errflg) - integer, intent(in) :: nmu - integer, intent(in) :: nlambda - real(kind_phys), intent(in) :: g_mu(:) - real(kind_phys), intent(in) :: g_lambda(:,:) - real(kind_phys), intent(in) :: lamc ! prognosed value of lambda for cloud - real(kind_phys), intent(in) :: pgam ! prognosed value of mu for cloud + ! Get mu and lambda interpolation weights + integer, intent(in) :: nmu ! number of mu values + integer, intent(in) :: nlambda ! number of lambda values + real(kind_phys), intent(in) :: g_mu(:) ! mu values + real(kind_phys), intent(in) :: g_lambda(:,:) ! lambda table + real(kind_phys), intent(in) :: lamc ! prognosed value of lambda for cloud + real(kind_phys), 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 + type(interp_type), intent(out) :: mu_wgts ! mu interpolation weights + type(interp_type), intent(out) :: lambda_wgts ! lambda interpolation weights character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 b/src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 index e4caf6f285..c5d7e892f6 100644 --- a/src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 +++ b/src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 @@ -34,12 +34,12 @@ subroutine rrtmgp_dry_static_energy_tendency_run(ncol, pdel, calc_sw_heat, calc_ !----------------------------------------------------------------------- ! Arguments - integer, intent(in) :: ncol - real(kind_phys), dimension(:,:), intent(in) :: pdel - logical, intent(in) :: calc_sw_heat - logical, intent(in) :: calc_lw_heat - real(kind_phys), dimension(:,:), intent(inout) :: qrs ! shortwave heating - real(kind_phys), dimension(:,:), intent(inout) :: qrl ! longwave heating + integer, intent(in) :: ncol ! Number of columns + real(kind_phys), dimension(:,:), intent(in) :: pdel ! Layer thickness + logical, intent(in) :: calc_sw_heat ! Flag to calculate net shortwave heating + logical, intent(in) :: calc_lw_heat ! Flag to calculate net longwave heating + real(kind_phys), dimension(:,:), intent(inout) :: qrs ! shortwave heating rate (J kg-1 s-1) + real(kind_phys), dimension(:,:), intent(inout) :: qrl ! longwave heating rate (J kg-1 s-1) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 index 5cdcd259fd..2dec2cb420 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs.F90 @@ -25,48 +25,51 @@ subroutine rrtmgp_inputs_init(ktopcam, ktoprad, nlaycam, sw_low_bounds, sw_high_ nextsw_cday, current_cal_day, band2gpt_sw, errmsg, errflg) ! Inputs - integer, intent(in) :: nswbands - integer, intent(in) :: pverp - integer, intent(in) :: pver - integer, intent(in) :: iradsw - integer, intent(in) :: timestep_size - integer, intent(in) :: nstep - integer, intent(in) :: nlwbands - integer, intent(in) :: nradgas - integer, intent(in) :: iulog - integer, intent(in) :: gasnamelength - real(kind_phys), intent(in) :: current_cal_day - real(kind_phys), dimension(:), intent(in) :: pref_edge - type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw - type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw - logical, intent(in) :: is_first_step - logical, intent(in) :: is_first_restart_step - logical, intent(in) :: use_rad_dt_cosz + integer, intent(in) :: nswbands + integer, intent(in) :: nlwbands ! Number of longwave bands + integer, intent(in) :: nradgas ! Number of radiatively active gases + integer, intent(in) :: pverp ! Number of vertical interfaces + integer, intent(in) :: pver ! Number of vertical layers + integer, intent(in) :: iradsw ! Freq. of shortwave radiation calc in time steps (positive) or hours (negative). + integer, intent(in) :: timestep_size ! Timestep size (s) + integer, intent(in) :: nstep ! Current timestep number + integer, intent(in) :: iulog ! Logging unit + integer, intent(in) :: gasnamelength ! Length of all of the gas_list entries + real(kind_phys), intent(in) :: current_cal_day ! Current calendar day + real(kind_phys), dimension(:), intent(in) :: pref_edge ! Reference pressures (interfaces) (Pa) + type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw ! Shortwave gas optics object + type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw ! Longwave gas optics object + logical, intent(in) :: is_first_step ! Flag for whether this is the first timestep (.true. = yes) + logical, intent(in) :: is_first_restart_step ! Flag for whether this is the first restart step (.true. = yes) + logical, intent(in) :: use_rad_dt_cosz character(len=*), dimension(:), intent(in) :: gaslist ! Outputs - integer, intent(out) :: ktopcam - integer, intent(out) :: ktoprad - integer, intent(out) :: nlaycam - integer, intent(out) :: nlay - integer, intent(out) :: nlayp - integer, intent(out) :: idx_sw_diag - integer, intent(out) :: idx_nir_diag - integer, intent(out) :: idx_uv_diag - integer, intent(out) :: idx_sw_cloudsim - integer, intent(out) :: idx_lw_diag - integer, intent(out) :: idx_lw_cloudsim - integer, intent(out) :: nswgpts - integer, intent(out) :: nlwgpts - integer, dimension(:,:), intent(out) :: band2gpt_sw - real(kind_phys), intent(out) :: nextsw_cday - real(kind_phys), dimension(:), intent(out) :: sw_low_bounds - real(kind_phys), dimension(:), intent(out) :: sw_high_bounds - real(kind_phys), dimension(:,:), intent(out) :: qrl + integer, intent(out) :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which RRTMGP is active + integer, intent(out) :: ktoprad ! Index in RRTMGP array corresponding to top layer or interface of CAM arrays + integer, intent(out) :: nlaycam ! Number of vertical layers in CAM. Is either equal to nlay + ! or is 1 less than nlay if "extra layer" is used in the radiation calculations + integer, intent(out) :: nlay ! Number of vertical layers in radiation calculation + integer, intent(out) :: nlayp ! Number of vertical interfaces in radiation calculations (nlay + 1) + ! Indices to specific bands for diagnostic output and COSP input + integer, intent(out) :: idx_sw_diag ! Index of band containing 500-nm wave + integer, intent(out) :: idx_nir_diag ! Index of band containing 1000-nm wave + integer, intent(out) :: idx_uv_diag ! Index of band containing 400-nm wave + integer, intent(out) :: idx_sw_cloudsim ! Index of band for shortwave cosp diagnostics + integer, intent(out) :: idx_lw_diag ! Index of band containing 1000-cm-1 wave (H2O window) + integer, intent(out) :: idx_lw_cloudsim ! Index of band for longwave cosp diagnostics + + integer, intent(out) :: nswgpts ! Number of shortwave g-points + integer, intent(out) :: nlwgpts ! Number of longwave g-points + integer, dimension(:,:), intent(out) :: band2gpt_sw ! Array for converting shortwave band limits to g-points + real(kind_phys), intent(out) :: nextsw_cday ! The next calendar day during which the shortwave radiation calculation will be performed + real(kind_phys), dimension(:), intent(out) :: sw_low_bounds ! Lower bounds of shortwave bands + real(kind_phys), dimension(:), intent(out) :: sw_high_bounds ! Upper bounds of shortwave bands + real(kind_phys), dimension(:,:), intent(out) :: qrl ! Longwave radiative heating character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - integer, intent(inout) :: irad_always - real(kind_phys), intent(inout) :: dt_avg ! averaging time interval for zenith angle + integer, intent(inout) :: irad_always ! Number of time steps to execute radiation continuously + real(kind_phys), intent(inout) :: dt_avg ! averaging time interval for zenith angle ! Local variables real(kind_phys), target :: wavenumber_low_shortwave(nswbands) @@ -168,62 +171,62 @@ subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & sources_lw, aer_sw, atm_optics_sw, gas_concs_sw, & errmsg, errflg) ! Inputs - logical, intent(in) :: graupel_in_rad - integer, intent(in) :: ncol - integer, intent(in) :: pver - integer, intent(in) :: pverp - integer, intent(in) :: nlay - integer, intent(in) :: nswbands - integer, intent(in) :: ktopcam - integer, intent(in) :: ktoprad - integer, intent(in) :: gasnamelength - integer, intent(in) :: nday - logical, intent(in) :: dosw - logical, intent(in) :: dolw - logical, intent(in) :: snow_associated - logical, intent(in) :: graupel_associated - integer, dimension(:), intent(in) :: idxday - real(kind_phys), dimension(:,:), intent(in) :: pmid - real(kind_phys), dimension(:,:), intent(in) :: pint - real(kind_phys), dimension(:,:), intent(in) :: t - real(kind_phys), dimension(:,:), intent(in) :: cldfsnow - real(kind_phys), dimension(:,:), intent(in) :: cldfgrau - real(kind_phys), dimension(:,:), intent(in) :: cld - real(kind_phys), dimension(:), intent(in) :: sw_low_bounds - real(kind_phys), dimension(:), intent(in) :: sw_high_bounds - real(kind_phys), dimension(:), intent(in) :: coszrs - real(kind_phys), dimension(:), intent(in) :: lwup - real(kind_phys), dimension(:), intent(in) :: asdir - real(kind_phys), dimension(:), intent(in) :: asdif - real(kind_phys), dimension(:), intent(in) :: aldir - real(kind_phys), dimension(:), intent(in) :: aldif - real(kind_phys), intent(in) :: stebol ! stefan-boltzmann constant - type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw ! spectral information - type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw ! spectral information - character(len=*), dimension(:), intent(in) :: gaslist + logical, intent(in) :: graupel_in_rad ! Flag to include graupel in radiation calculation + integer, intent(in) :: ncol ! Number of columns + integer, intent(in) :: pver ! Number of vertical layers + integer, intent(in) :: pverp ! Number of vertical interfaces + integer, intent(in) :: nlay ! Number of vertical layers used in radiation calculation + integer, intent(in) :: nswbands ! Number of shortwave bands + integer, intent(in) :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which RRTMGP is active + integer, intent(in) :: ktoprad ! Index in RRTMGP array corresponding to top layer or interface of CAM arrays + integer, intent(in) :: gasnamelength ! Length of gases in gas_list + integer, intent(in) :: nday ! Number of daylight columns + logical, intent(in) :: dosw ! Flag for performing the shortwave calculation + logical, intent(in) :: dolw ! Flag for performing the longwave calculation + logical, intent(in) :: snow_associated ! Flag for whether the cloud snow fraction argument should be used + logical, intent(in) :: graupel_associated ! Flag for whether the cloud graupel fraction argument should be used + integer, dimension(:), intent(in) :: idxday ! Indices of daylight columns + real(kind_phys), dimension(:,:), intent(in) :: pmid ! Air pressure at midpoint (Pa) + real(kind_phys), dimension(:,:), intent(in) :: pint ! Air pressure at interface (Pa) + real(kind_phys), dimension(:,:), intent(in) :: t ! Air temperature (K) + real(kind_phys), dimension(:,:), intent(in) :: cldfsnow ! Cloud fraction of just "snow clouds" + real(kind_phys), dimension(:,:), intent(in) :: cldfgrau ! Cloud fraction of just "graupel clouds" + real(kind_phys), dimension(:,:), intent(in) :: cld ! Cloud fraction (liq+ice) + real(kind_phys), dimension(:), intent(in) :: sw_low_bounds ! Lower bounds for shortwave bands + real(kind_phys), dimension(:), intent(in) :: sw_high_bounds ! Upper bounds for shortwave bands + real(kind_phys), dimension(:), intent(in) :: coszrs ! Cosine of solar senith angle (radians) + real(kind_phys), dimension(:), intent(in) :: lwup ! Longwave up flux (W m-2) + real(kind_phys), dimension(:), intent(in) :: asdir ! Shortwave direct albedo (fraction) + real(kind_phys), dimension(:), intent(in) :: asdif ! Shortwave diffuse albedo (fraction) + real(kind_phys), dimension(:), intent(in) :: aldir ! Longwave direct albedo (fraction) + real(kind_phys), dimension(:), intent(in) :: aldif ! Longwave diffuse albedo (fraction) + real(kind_phys), intent(in) :: stebol ! Stefan-Boltzmann constant (W m-2 K-4) + type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw ! Shortwave gas optics object + type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw ! Longwave gas optics object + character(len=*), dimension(:), intent(in) :: gaslist ! Radiatively active gases ! Outputs - real(kind_phys), dimension(:,:), intent(out) :: t_rad - real(kind_phys), dimension(:,:), intent(out) :: pmid_rad - real(kind_phys), dimension(:,:), intent(out) :: pint_rad - real(kind_phys), dimension(:,:), intent(out) :: t_day - real(kind_phys), dimension(:,:), intent(out) :: pint_day - real(kind_phys), dimension(:,:), intent(out) :: pmid_day - real(kind_phys), dimension(:,:), intent(out) :: emis_sfc - real(kind_phys), dimension(:,:), intent(out) :: alb_dir - real(kind_phys), dimension(:,:), intent(out) :: alb_dif - real(kind_phys), dimension(:,:), intent(out) :: cldfprime ! modiifed cloud fraciton - - real(kind_phys), dimension(:), intent(out) :: t_sfc - real(kind_phys), dimension(:), intent(out) :: coszrs_day - type(ty_gas_concs_ccpp), intent(out) :: gas_concs_lw - type(ty_optical_props_1scl_ccpp), intent(out) :: atm_optics_lw - type(ty_optical_props_1scl_ccpp), intent(out) :: aer_lw - type(ty_source_func_lw_ccpp), intent(out) :: sources_lw - type(ty_gas_concs_ccpp), intent(out) :: gas_concs_sw - type(ty_optical_props_2str_ccpp), intent(out) :: atm_optics_sw - type(ty_optical_props_2str_ccpp), intent(out) :: aer_sw - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), dimension(:,:), intent(out) :: t_rad ! Air temperature with radiation indexing (K) + real(kind_phys), dimension(:,:), intent(out) :: pmid_rad ! Midpoint pressure with radiation indexing (Pa) + real(kind_phys), dimension(:,:), intent(out) :: pint_rad ! Interface pressure with radiation indexing (Pa) + real(kind_phys), dimension(:,:), intent(out) :: t_day ! Air temperature of daylight columns (K) + real(kind_phys), dimension(:,:), intent(out) :: pint_day ! Interface pressure of daylight columns (Pa) + real(kind_phys), dimension(:,:), intent(out) :: pmid_day ! Midpoint pressure of daylight columns (Pa) + real(kind_phys), dimension(:,:), intent(out) :: emis_sfc ! Surface emissivity (fraction) + real(kind_phys), dimension(:,:), intent(out) :: alb_dir ! Surface albedo due to UV and VIS direct (fraction) + real(kind_phys), dimension(:,:), intent(out) :: alb_dif ! Surface albedo due to IR diffused (fraction) + real(kind_phys), dimension(:,:), intent(out) :: cldfprime ! modified cloud fraciton + + real(kind_phys), dimension(:), intent(out) :: t_sfc ! Surface temperature (K) + real(kind_phys), dimension(:), intent(out) :: coszrs_day ! Cosine of solar zenith angle for daylight columns (radians) + type(ty_gas_concs_ccpp), intent(out) :: gas_concs_lw ! Gas concentrations object for longwave radiation + type(ty_optical_props_1scl_ccpp), intent(out) :: atm_optics_lw ! Atmosphere optical properties object for longwave radiation + type(ty_optical_props_1scl_ccpp), intent(out) :: aer_lw ! Aerosol optical properties object for longwave radiation + type(ty_source_func_lw_ccpp), intent(out) :: sources_lw ! Longwave sources object for longwave radiation + type(ty_gas_concs_ccpp), intent(out) :: gas_concs_sw ! Gas concentrations object for shortwave radiation + type(ty_optical_props_2str_ccpp), intent(out) :: atm_optics_sw ! Atmosphere optical properties object for shortwave radiation + type(ty_optical_props_2str_ccpp), intent(out) :: aer_sw ! Aerosol optical properties object for shortwave radiation + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! Local variables real(kind_phys) :: tref_min @@ -445,24 +448,24 @@ subroutine set_wavenumber_bands(kdist_sw, kdist_lw, nswbands, nlwbands, idx_sw_d ! Arguments type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw - integer, intent(in) :: nswbands - integer, intent(in) :: nlwbands - - integer, intent(out) :: idx_sw_diag - integer, intent(out) :: idx_nir_diag - integer, intent(out) :: idx_uv_diag - integer, intent(out) :: idx_sw_cloudsim - integer, intent(out) :: idx_lw_diag - integer, intent(out) :: idx_lw_cloudsim - integer, intent(out) :: nswgpts - integer, intent(out) :: nlwgpts - integer, dimension(:,:), intent(out) :: band2gpt_sw - real(kind_phys), dimension(:), intent(out) :: wavenumber_low_shortwave - real(kind_phys), dimension(:), intent(out) :: wavenumber_high_shortwave - real(kind_phys), dimension(:), intent(out) :: wavenumber_low_longwave - real(kind_phys), dimension(:), intent(out) :: wavenumber_high_longwave - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: nswbands + integer, intent(in) :: nlwbands + + integer, intent(out) :: idx_sw_diag + integer, intent(out) :: idx_nir_diag + integer, intent(out) :: idx_uv_diag + integer, intent(out) :: idx_sw_cloudsim + integer, intent(out) :: idx_lw_diag + integer, intent(out) :: idx_lw_cloudsim + integer, intent(out) :: nswgpts + integer, intent(out) :: nlwgpts + integer, dimension(:,:), intent(out) :: band2gpt_sw + real(kind_phys), dimension(:), intent(out) :: wavenumber_low_shortwave + real(kind_phys), dimension(:), intent(out) :: wavenumber_high_shortwave + real(kind_phys), dimension(:), intent(out) :: wavenumber_low_longwave + real(kind_phys), dimension(:), intent(out) :: wavenumber_high_longwave + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! Local variables integer :: istat @@ -561,15 +564,15 @@ subroutine get_band_index_by_value(swlw, targetvalue, units, nbnds, wavenumber_l ! Find band index for requested wavelength/wavenumber. - character(len=*), intent(in) :: swlw ! sw or lw bands - real(kind_phys), intent(in) :: targetvalue - character(len=*), intent(in) :: units ! units of targetvalue - integer, intent(in) :: nbnds + character(len=*), intent(in) :: swlw ! sw or lw bands + real(kind_phys), intent(in) :: targetvalue + character(len=*), intent(in) :: units ! units of targetvalue + integer, intent(in) :: nbnds real(kind_phys), target, dimension(:), intent(in) :: wavenumber_low real(kind_phys), target, dimension(:), intent(in) :: wavenumber_high - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(out) :: ans + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(out) :: ans ! local real(kind_phys), pointer, dimension(:) :: lowboundaries, highboundaries diff --git a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 index c65c2e3243..61d5168129 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 @@ -42,16 +42,16 @@ subroutine rrtmgp_lw_cloud_optics_init(nmu_in, nlambda_in, n_g_d_in, & abs_lw_liq_in, abs_lw_ice_in, nlwbands, g_mu_in, g_lambda_in, & g_d_eff_in, tiny_in, errmsg, errflg) ! Inputs - integer, intent(in) :: nmu_in - integer, intent(in) :: nlambda_in - integer, intent(in) :: n_g_d_in - integer, intent(in) :: nlwbands - real(kind_phys), dimension(:,:,:), intent(in) :: abs_lw_liq_in - real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice_in - real(kind_phys), dimension(:,:), intent(in) :: g_lambda_in - real(kind_phys), dimension(:), intent(in) :: g_mu_in - real(kind_phys), dimension(:), intent(in) :: g_d_eff_in - real(kind_phys), intent(in) :: tiny_in + integer, intent(in) :: nmu_in ! Number of mu samples on grid + integer, intent(in) :: nlambda_in ! Number of lambda scale samples on grid + integer, intent(in) :: n_g_d_in ! Number of radiative effective diameter samples on grid + integer, intent(in) :: nlwbands ! Number of longwave bands + real(kind_phys), dimension(:,:,:), intent(in) :: abs_lw_liq_in ! Longwave mass specific absorption for in-cloud liquid water path + real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice_in ! Longwave mass specific absorption for in-cloud ice water path + real(kind_phys), dimension(:,:), intent(in) :: g_lambda_in ! lambda scale samples on grid + real(kind_phys), dimension(:), intent(in) :: g_mu_in ! Mu samples on grid + real(kind_phys), dimension(:), intent(in) :: g_d_eff_in ! Radiative effective diameter samples on grid + real(kind_phys), intent(in) :: tiny_in ! Definition of what "tiny" means ! Outputs character(len=*), intent(out) :: errmsg @@ -111,48 +111,44 @@ end subroutine rrtmgp_lw_cloud_optics_init !> \section arg_table_rrtmgp_lw_cloud_optics_run Argument Table !! \htmlinclude rrtmgp_lw_cloud_optics_run.html !! - subroutine rrtmgp_lw_cloud_optics_run(ncol, nlay, nlaycam, cld, cldfsnow, cldfgrau, & - cldfprime, graupel_in_rad, kdist_lw, cloud_lw, lamc, pgam, iclwpth, iciwpth, & - dei, icswpth, des, icgrauwpth, degrau, nlwbands, do_snow, & - do_graupel, cld_lw_abs_cloudsim, snow_lw_abs_cloudsim, pver, ktopcam, & - grau_lw_abs_cloudsim, idx_lw_cloudsim, tauc, cldf, errmsg, errflg) + subroutine rrtmgp_lw_cloud_optics_run(dolw, ncol, nlay, nlaycam, cld, cldfsnow, cldfgrau, & + cldfprime, graupel_in_rad, kdist_lw, cloud_lw, lamc, pgam, iclwpth, iciwpth, & + dei, icswpth, des, icgrauwpth, degrau, nlwbands, do_snow, & + do_graupel, pver, ktopcam, tauc, cldf, errmsg, errflg) ! 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 ! Inputs - integer, intent(in) :: ncol - integer, intent(in) :: nlay - integer, intent(in) :: nlaycam - integer, intent(in) :: nlwbands - integer, intent(in) :: pver - integer, intent(in) :: ktopcam - integer, intent(in) :: idx_lw_cloudsim - real(kind_phys), dimension(:,:), intent(in) :: cld - real(kind_phys), dimension(:,:), intent(in) :: cldfsnow - real(kind_phys), dimension(:,:), intent(in) :: cldfgrau - real(kind_phys), dimension(:,:), intent(in) :: cldfprime - real(kind_phys), dimension(:,:), intent(in) :: lamc - real(kind_phys), dimension(:,:), intent(in) :: pgam - real(kind_phys), dimension(:,:), intent(in) :: iclwpth - real(kind_phys), dimension(:,:), intent(in) :: iciwpth - real(kind_phys), dimension(:,:), intent(in) :: icswpth - real(kind_phys), dimension(:,:), intent(in) :: icgrauwpth - real(kind_phys), dimension(:,:), intent(in) :: dei - real(kind_phys), dimension(:,:), intent(in) :: des - real(kind_phys), dimension(:,:), intent(in) :: degrau - logical, intent(in) :: graupel_in_rad - logical, intent(in) :: do_snow - logical, intent(in) :: do_graupel - class(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw + integer, intent(in) :: ncol ! Number of columns + integer, intent(in) :: nlay ! Number of vertical layers in radiation + integer, intent(in) :: nlaycam ! Number of model layers in radiation + integer, intent(in) :: nlwbands ! Number of longwave bands + integer, intent(in) :: pver ! Total number of vertical layers + integer, intent(in) :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which RRTMGP is active + real(kind_phys), dimension(:,:), intent(in) :: cld ! Cloud fraction (liq + ice) + real(kind_phys), dimension(:,:), intent(in) :: cldfsnow ! Cloud fraction of just "snow clouds" + real(kind_phys), dimension(:,:), intent(in) :: cldfgrau ! Cloud fraction of just "graupel clouds" + real(kind_phys), dimension(:,:), intent(in) :: cldfprime ! Modified cloud fraction + real(kind_phys), dimension(:,:), intent(in) :: lamc ! Prognosed value of lambda for cloud + real(kind_phys), dimension(:,:), intent(in) :: pgam ! Prognosed value of mu for cloud + real(kind_phys), dimension(:,:), intent(in) :: iclwpth ! In-cloud liquid water path + real(kind_phys), dimension(:,:), intent(in) :: iciwpth ! In-cloud ice water path + real(kind_phys), dimension(:,:), intent(in) :: icswpth ! In-cloud snow water path + real(kind_phys), dimension(:,:), intent(in) :: icgrauwpth ! In-cloud graupel water path + real(kind_phys), dimension(:,:), intent(in) :: dei ! Mean effective radius for ice cloud + real(kind_phys), dimension(:,:), intent(in) :: des ! Mean effective radius for snow + real(kind_phys), dimension(:,:), intent(in) :: degrau ! Mean effective radius for graupel + logical, intent(in) :: graupel_in_rad ! Flag for whether to include graupel in calculation + logical, intent(in) :: do_snow ! Flag for whether cldfsnow is present + logical, intent(in) :: do_graupel ! Flag for whether cldfgrau is present + logical, intent(in) :: dolw ! Flag for whether to perform longwave calculation + class(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw ! Longwave gas optics object ! Outputs - type(ty_optical_props_1scl_ccpp), intent(out) :: cloud_lw - real(kind_phys), dimension(:,:), intent(out) :: cld_lw_abs_cloudsim - real(kind_phys), dimension(:,:), intent(out) :: snow_lw_abs_cloudsim - real(kind_phys), dimension(:,:), intent(out) :: grau_lw_abs_cloudsim - real(kind_phys), dimension(:,:), intent(out) :: cldf - real(kind_phys), dimension(:,:,:), intent(out) :: tauc + type(ty_optical_props_1scl_ccpp), intent(out) :: cloud_lw ! Longwave cloud optics object + real(kind_phys), dimension(:,:), intent(out) :: cldf ! Subset cloud fraction + real(kind_phys), dimension(:,:,:), intent(out) :: tauc ! Cloud optical depth character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -170,6 +166,15 @@ subroutine rrtmgp_lw_cloud_optics_run(ncol, nlay, nlaycam, cld, cldfsnow, cldfgr character(len=*), parameter :: sub = 'rrtmgp_lw_cloud_optics_run' !-------------------------------------------------------------------------------- + ! Set error variables + errmsg = '' + errflg = 0 + + ! If not doing longwave, no need to proceed + if (.not. dolw) then + return + end if + ! Combine the cloud optical properties. ! gammadist liquid optics @@ -227,11 +232,6 @@ subroutine rrtmgp_lw_cloud_optics_run(ncol, nlay, nlaycam, cld, cldfsnow, cldfgr 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,:,:) - ! Extract just the layers of CAM where RRTMGP does calculations ! Subset "chunk" data so just the number of CAM layers in the diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 index 87c270b417..d91afadbf6 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 @@ -22,24 +22,24 @@ subroutine rrtmgp_lw_gas_optics_run(dolw, iter_num, ncol, rrtmgp_phys_blksz, p_l gas_concs, lw_optical_props_clrsky, sources, t_lev, include_interface_temp, lw_gas_props, & errmsg, errflg) ! Inputs - logical, intent(in) :: dolw - logical, intent(in) :: include_interface_temp - integer, intent(in) :: iter_num - integer, intent(in) :: ncol - integer, intent(in) :: rrtmgp_phys_blksz - real(kind_phys), dimension(:,:), intent(in) :: p_lay - real(kind_phys), dimension(:,:), intent(in) :: p_lev - real(kind_phys), dimension(:,:), intent(in) :: t_lay - real(kind_phys), dimension(:), intent(in) :: tsfg - real(kind_phys), dimension(:,:), intent(in) :: t_lev - type(ty_gas_concs_ccpp), intent(in) :: gas_concs !< RRTMGP gas concentrations object + logical, intent(in) :: dolw !< Flag for whether to perform longwave calculation + logical, intent(in) :: include_interface_temp !< Flag for whether to include interface temperature in calculation + integer, intent(in) :: iter_num !< Subcycle iteration number + integer, intent(in) :: ncol !< Total number of columns + integer, intent(in) :: rrtmgp_phys_blksz !< Number of horizontal points to process at once + real(kind_phys), dimension(:,:), intent(in) :: p_lay !< Air pressure at midpoints [Pa] + real(kind_phys), dimension(:,:), intent(in) :: p_lev !< Air pressure at interfaces [Pa] + real(kind_phys), dimension(:,:), intent(in) :: t_lay !< Air temperature at midpoints [K] + real(kind_phys), dimension(:), intent(in) :: tsfg !< Surface skin temperature [K] + real(kind_phys), dimension(:,:), intent(in) :: t_lev !< Air temperature at interfaces [K] + type(ty_gas_concs_ccpp), intent(in) :: gas_concs !< RRTMGP gas concentrations object ! Outputs type(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clrsky !< Clearsky optical properties - type(ty_source_func_lw_ccpp), intent(inout) :: sources + type(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: lw_gas_props !< RRTMGP gas optics object + type(ty_source_func_lw_ccpp), intent(inout) :: sources !< Longwave sources object character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - type(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: lw_gas_props !< RRTMGP gas optics object ! Local variables integer :: iCol, iCol2 @@ -54,25 +54,34 @@ subroutine rrtmgp_lw_gas_optics_run(dolw, iter_num, ncol, rrtmgp_phys_blksz, p_l iCol = ((iter_num - 1) * rrtmgp_phys_blksz) + 1 iCol2= min(iCol + rrtmgp_phys_blksz - 1, ncol) + if (include_interface_temp) then - call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_props%gas_optics(& - p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) - tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) - gas_concs%gas_concs, & ! IN - RRTMGP DDT: trace gas volume mixing-ratios - lw_optical_props_clrsky%optical_props, & ! OUT - RRTMGP DDT: longwave optical properties - sources%sources, & ! OUT - RRTMGP DDT: source functions - tlev=t_lev(iCol:iCol2,:))) ! IN - Temperature @ layer-interfaces (K) (optional) + errmsg = lw_gas_props%gas_props%gas_optics(& + p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) + tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) + gas_concs%gas_concs, & ! IN - RRTMGP DDT: trace gas volume mixing-ratios + lw_optical_props_clrsky%optical_props, & ! OUT - RRTMGP DDT: longwave optical properties + sources%sources, & ! OUT - RRTMGP DDT: source functions + tlev=t_lev(iCol:iCol2,:)) ! IN - Temperature @ layer-interfaces (K) (optional) + call check_error_msg('rrtmgp_lw_main_gas_optics', errmsg) + if (len_trim(errmsg) /= 0) then + errflg = 1 + end if else - call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_props%gas_optics(& - p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) - tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) - gas_concs%gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - lw_optical_props_clrsky%optical_props, & ! OUT - RRTMGP DDT: longwave optical properties - sources%sources)) ! OUT - RRTMGP DDT: source functions + errmsg = lw_gas_props%gas_props%gas_optics(& + p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) + p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) + t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) + tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) + gas_concs%gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios + lw_optical_props_clrsky%optical_props, & ! OUT - RRTMGP DDT: longwave optical properties + sources%sources) ! OUT - RRTMGP DDT: source functions + call check_error_msg('rrtmgp_lw_main_gas_optics', errmsg) + if (len_trim(errmsg) /= 0) then + errflg = 1 + end if end if end subroutine rrtmgp_lw_gas_optics_run diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 index a2a27195fe..3de9f2f9ea 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 @@ -7,6 +7,7 @@ module rrtmgp_lw_gas_optics_data use machine, only: kind_phys use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp use ccpp_gas_concentrations, only: ty_gas_concs_ccpp + use radiation_tools, only: check_error_msg implicit none @@ -27,44 +28,44 @@ subroutine rrtmgp_lw_gas_optics_data_init(kdist, available_gases, gas_names, errmsg, errflg) ! Inputs - class(ty_gas_concs_ccpp), intent(in) :: available_gases - character(len=*), dimension(:), intent(in) :: gas_names - character(len=*), dimension(:), intent(in) :: gas_minor - character(len=*), dimension(:), intent(in) :: identifier_minor - character(len=*), dimension(:), intent(in) :: minor_gases_lower - character(len=*), dimension(:), intent(in) :: minor_gases_upper - character(len=*), dimension(:), intent(in) :: scaling_gas_lower - character(len=*), dimension(:), intent(in) :: scaling_gas_upper - integer, dimension(:,:,:), intent(in) :: key_species - integer, dimension(:,:), intent(in) :: band2gpt - integer, dimension(:,:), intent(in) :: minor_limits_gpt_lower - integer, dimension(:,:), intent(in) :: minor_limits_gpt_upper - integer, dimension(:), intent(in) :: kminor_start_lower - integer, dimension(:), intent(in) :: kminor_start_upper - logical, dimension(:), intent(in) :: minor_scales_with_density_lower - logical, dimension(:), intent(in) :: scale_by_complement_lower - logical, dimension(:), intent(in) :: minor_scales_with_density_upper - logical, dimension(:), intent(in) :: scale_by_complement_upper - real(kind_phys), dimension(:,:,:,:), intent(in) :: kmajor - real(kind_phys), dimension(:,:,:,:), intent(in) :: planck_frac - real(kind_phys), dimension(:,:,:), intent(in) :: kminor_lower - real(kind_phys), dimension(:,:,:), intent(in) :: kminor_upper - real(kind_phys), dimension(:,:,:), intent(in) :: vmr_ref - real(kind_phys), dimension(:,:,:), allocatable, intent(in) :: rayl_lower - real(kind_phys), dimension(:,:,:), allocatable, intent(in) :: rayl_upper - real(kind_phys), dimension(:,:), intent(in) :: band_lims_wavenum - real(kind_phys), dimension(:,:), intent(in) :: totplnk - real(kind_phys), dimension(:,:), intent(in) :: optimal_angle_fit - real(kind_phys), dimension(:), intent(in) :: press_ref - real(kind_phys), dimension(:), intent(in) :: temp_ref - real(kind_phys), intent(in) :: press_ref_trop - real(kind_phys), intent(in) :: temp_ref_p - real(kind_phys), intent(in) :: temp_ref_t + class(ty_gas_concs_ccpp), intent(in) :: available_gases ! Gas concentrations object + character(len=*), dimension(:), intent(in) :: gas_names ! Names of absorbing gases + character(len=*), dimension(:), intent(in) :: gas_minor ! Name of absorbing minor gas + character(len=*), dimension(:), intent(in) :: identifier_minor ! Unique string identifying minor gas + character(len=*), dimension(:), intent(in) :: minor_gases_lower ! Names of minor absorbing gases in lower atmosphere + character(len=*), dimension(:), intent(in) :: minor_gases_upper ! Names of minor absorbing gases in upper atmosphere + character(len=*), dimension(:), intent(in) :: scaling_gas_lower ! Absorption also depends on the concentration of this gas in the lower atmosphere + character(len=*), dimension(:), intent(in) :: scaling_gas_upper ! Absorption also depends on the concentration of this gas in the upper atmosphere + integer, dimension(:,:,:), intent(in) :: key_species ! Key species pair for each band + integer, dimension(:,:), intent(in) :: band2gpt ! Array for converting shortwave band limits to g-points + integer, dimension(:,:), intent(in) :: minor_limits_gpt_lower ! Beginning and ending gpoint for each minor interval in lower atmosphere + integer, dimension(:,:), intent(in) :: minor_limits_gpt_upper ! Beginning and ending gpoint for each minor interval in upper atmosphere + integer, dimension(:), intent(in) :: kminor_start_lower ! Starting index in the [1,nContributors] vector for a contributor given by "minor_gases_lower" + integer, dimension(:), intent(in) :: kminor_start_upper ! Starting index in the [1,nContributors] vector for a contributor given by "minor_gases_upper" + logical, dimension(:), intent(in) :: minor_scales_with_density_lower ! Density scaling is applied to minor absorption coefficients in the lower atmosphere + logical, dimension(:), intent(in) :: scale_by_complement_lower ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) in the lower atmosphere + logical, dimension(:), intent(in) :: minor_scales_with_density_upper ! Density scaling is applied to minor absorption coefficients in the upper atmosphere + logical, dimension(:), intent(in) :: scale_by_complement_upper ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) in the upper atmosphere + real(kind_phys), dimension(:,:,:,:), intent(in) :: kmajor ! Stored absorption coefficients due to major absorbing gases + real(kind_phys), dimension(:,:,:,:), intent(in) :: planck_frac ! Fraction of band-integrated Planck energy associated with each g-point + real(kind_phys), dimension(:,:,:), intent(in) :: kminor_lower ! Transformed from [nTemp x nEta x nGpt x nAbsorbers] array to [nTemp x nEta x nContributors] array + real(kind_phys), dimension(:,:,:), intent(in) :: kminor_upper ! Transformed from [nTemp x nEta x nGpt x nAbsorbers] array to [nTemp x nEta x nContributors] array + real(kind_phys), dimension(:,:,:), intent(in) :: vmr_ref ! Volume mixing ratios for reference atmosphere + real(kind_phys), dimension(:,:), intent(in) :: band_lims_wavenum ! Beginning and ending wavenumber for each band [cm-1] + real(kind_phys), dimension(:,:), intent(in) :: totplnk ! Integrated Planck function by band + real(kind_phys), dimension(:,:), intent(in) :: optimal_angle_fit ! Coefficients for linear fit used in longwave optimal angle RT calculation + real(kind_phys), dimension(:), intent(in) :: press_ref ! Pressures for reference atmosphere [Pa] + real(kind_phys), dimension(:), intent(in) :: temp_ref ! Temperatures for reference atmosphere [K] + real(kind_phys), intent(in) :: press_ref_trop ! Reference pressure separating the lower and upper atmosphere [Pa] + real(kind_phys), intent(in) :: temp_ref_p ! Standard spectroscopic reference pressure [Pa] + real(kind_phys), intent(in) :: temp_ref_t ! Standard spectroscopic reference temperature [K] + real(kind_phys), dimension(:,:,:), allocatable, intent(in) :: rayl_lower ! Stored coefficients due to rayleigh scattering contribution in lower part of atmosphere + real(kind_phys), dimension(:,:,:), allocatable, intent(in) :: rayl_upper ! Stored coefficients due to rayleigh scattering contribution in upper part of atmosphere ! Outputs - class(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: kdist !< RRTMGP gas optics object - character(len=*), intent(out) :: errmsg !< CCPP error message - integer, intent(out) :: errflg !< CCPP error code + class(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: kdist ! RRTMGP gas optics object + character(len=*), intent(out) :: errmsg ! CCPP error message + integer, intent(out) :: errflg ! CCPP error code ! Initialize error variables errmsg = '' @@ -91,6 +92,7 @@ subroutine rrtmgp_lw_gas_optics_data_init(kdist, available_gases, gas_names, if (len_trim(errmsg) > 0) then errflg = 1 end if + call check_error_msg('rrtmgp_lw_gas_optics_init_load', errmsg) end subroutine rrtmgp_lw_gas_optics_data_init diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 index 13164c0378..9d94d5a05e 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 @@ -1,9 +1,3 @@ -!> \file rrtmgp_lw_gas_optics_pre.F90 -!! - -!> This module contains an init routine to initialize the k-distribution data -!! and functions needed to compute the longwave gaseous optical properties in RRTMGP. -!! It also contains a run routine to compute gas optics during the radiation subcycle module rrtmgp_lw_gas_optics_pre use machine, only: kind_phys use ccpp_gas_concentrations, only: ty_gas_concs_ccpp @@ -21,25 +15,22 @@ subroutine rrtmgp_lw_gas_optics_pre_run(icall, rad_const_array, pmid, pint, nlay ! 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. - - integer, intent(in) :: icall ! index of climate/diagnostic radiation call - character(len=*), intent(in) :: gaslist(:) - integer, intent(in) :: nlay ! number of layers in radiation calculation - integer, intent(in) :: ncol ! number of columns, ncol for LW, nday for SW - integer, intent(in) :: pverp - integer, intent(in) :: idxday(:) ! indices of daylight columns in a chunk - integer, intent(in) :: ktoprad - integer, intent(in) :: ktopcam - integer, intent(in) :: nradgas - logical, intent(in) :: dolw - real(kind_phys), intent(in) :: pmid(:,:) - real(kind_phys), intent(in) :: pint(:,:) + integer, intent(in) :: icall ! Subcycle index of climate/diagnostic radiation call + character(len=*), intent(in) :: gaslist(:) ! Radiatively active gases + integer, intent(in) :: nlay ! Number of layers in radiation calculation + integer, intent(in) :: ncol ! Total number of columns + integer, intent(in) :: pverp ! Total number of layer interfaces + integer, intent(in) :: idxday(:) ! Indices of daylight columns + integer, intent(in) :: ktoprad ! Index in RRTMGP array corresponding to top layer or interface of CAM arrays + integer, intent(in) :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which RRTMGP is active + integer, intent(in) :: nradgas ! Number of radiatively active gases + logical, intent(in) :: dolw ! Flag for whether to perform longwave calculaion + real(kind_phys), intent(in) :: pmid(:,:) ! Air pressure at midpoints [Pa] + real(kind_phys), intent(in) :: pint(:,:) ! Air pressure at interfaces [Pa] real(kind_phys), intent(in) :: rad_const_array(:,:,:) ! array of radiatively-active constituent vmrs ! last index corresponds to index in gaslist - type(ty_gas_concs_ccpp), intent(inout) :: gas_concs ! the result is VRM inside gas_concs + type(ty_gas_concs_ccpp), intent(inout) :: gas_concs ! the result is VMR inside gas_concs character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -130,8 +121,6 @@ subroutine rrtmgp_lw_gas_optics_pre_run(icall, rad_const_array, pmid, pint, nlay return end if -! deallocate(gas_vmr) -! deallocate(mmr) end do end subroutine rrtmgp_lw_gas_optics_pre_run diff --git a/src/physics/rrtmgp/rrtmgp_lw_main.F90 b/src/physics/rrtmgp/rrtmgp_lw_main.F90 index da7cfdd102..88b14c6f61 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_main.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_main.F90 @@ -1,7 +1,7 @@ !> \file rrtmgp_lw_main.F90 -!! This file contains the longwave RRTMGP radiation scheme. +!! This file contains the core longwave RRTMGP radiation calcuation -!> This module contains the call to the RRTMGP-LW radiation scheme +!> This module contains the call to the RRTMGP-LW radiation routine module rrtmgp_lw_main use machine, only: kind_phys use mo_rte_lw, only: rte_lw @@ -26,35 +26,34 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, aerlw, fluxlwUP_jac, lw_Ds, flux_clrsky, flux_allsky, errmsg, errflg) ! Inputs - logical, intent(in) :: doLWrad ! Flag to perform longwave calculation - logical, intent(in) :: doLWclrsky ! Flag to compute clear-sky fluxes - logical, intent(in) :: doGP_lwscat ! Flag to include scattering in clouds - logical, intent(in) :: use_LW_jacobian ! Flag to compute Jacobian - logical, intent(in) :: use_LW_optimal_angles ! Flag to compute and use optimal angles - logical, intent(in) :: top_at_1 ! Flag for vertical ordering convention + logical, intent(in) :: doLWrad !< Flag to perform longwave calculation + logical, intent(in) :: doLWclrsky !< Flag to compute clear-sky fluxes + logical, intent(in) :: doGP_lwscat !< Flag to include scattering in clouds + logical, intent(in) :: use_LW_jacobian !< Flag to compute Jacobian + logical, intent(in) :: use_LW_optimal_angles !< Flag to compute and use optimal angles + logical, intent(in) :: top_at_1 !< Flag for vertical ordering convention - integer, intent(in) :: nGauss_angles ! Number of gaussian quadrature angles used - integer, intent(in) :: nCol ! Number of horizontal points - integer, intent(in) :: iter_num ! RRTMGP iteration number - integer, intent(in) :: rrtmgp_phys_blksz ! Number of horizontal points to process at once + integer, intent(in) :: nGauss_angles !< Number of gaussian quadrature angles used + integer, intent(in) :: nCol !< Number of horizontal points + integer, intent(in) :: iter_num !< Radiation subcycle iteration number + integer, intent(in) :: rrtmgp_phys_blksz !< Number of horizontal points to process at once - real(kind_phys), dimension(:,:), intent(out) :: lw_Ds - real(kind_phys), dimension(:,:), intent(in) :: sfc_emiss_byband - - class(ty_source_func_lw_ccpp), intent(in) :: sources + real(kind_phys), dimension(:,:), intent(in) :: sfc_emiss_byband !< Surface emissivity by band + class(ty_source_func_lw_ccpp), intent(in) :: sources !< Longwave sources object ! Outputs - real(kind_phys), dimension(:,:), intent(inout) :: fluxlwUP_jac - class(ty_fluxes_byband_ccpp), intent(inout) :: flux_allsky - class(ty_fluxes_broadband_ccpp), intent(inout) :: flux_clrsky - class(ty_optical_props_1scl_ccpp), intent(inout) :: aerlw - class(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clrsky - class(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clouds + real(kind_phys), dimension(:,:), intent(inout) :: fluxlwUP_jac !< Surface temperature flux Jacobian [W m-2 K-1] + class(ty_fluxes_byband_ccpp), intent(inout) :: flux_allsky !< All-sky flux [W m-2] + class(ty_fluxes_broadband_ccpp), intent(inout) :: flux_clrsky !< Clear-sky flux [W m-2] + class(ty_optical_props_1scl_ccpp), intent(inout) :: aerlw !< Aerosol optical properties object + class(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clrsky !< Clear-sky optical properties object + class(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clouds !< Cloud optical properties object - class(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: lw_gas_props + class(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: lw_gas_props !< Gas optical properties object - character(len=*), intent(out) :: errmsg ! CCPP error message - integer, intent(out) :: errflg ! CCPP error flag + real(kind_phys), dimension(:,:), intent(out) :: lw_Ds !< 1/cos of transport angle per column, g-point + character(len=*), intent(out) :: errmsg !< CCPP error message + integer, intent(out) :: errflg !< CCPP error flag ! Local variables integer :: iCol, iCol2 @@ -74,37 +73,60 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, ! ! ################################################################################### ! Increment - call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky',& - aerlw%optical_props%increment(lw_optical_props_clrsky%optical_props)) + errmsg = aerlw%optical_props%increment(lw_optical_props_clrsky%optical_props) + call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + return + end if ! Call RTE solver if (doLWclrsky) then if (nGauss_angles .gt. 1) then - call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky%fluxes, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + errmsg = rte_lw( & + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_clrsky%fluxes, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles) ! IN - Number of angles in Gaussian quadrature + call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + return + end if else if (use_lw_optimal_angles) then - call check_error_msg('rrtmgp_lw_main_opt_angle',& - lw_gas_props%gas_props%compute_optimal_angles(lw_optical_props_clrsky%optical_props,lw_Ds)) - call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky%fluxes, & ! OUT - Fluxes - lw_Ds = lw_Ds)) + errmsg = lw_gas_props%gas_props%compute_optimal_angles(lw_optical_props_clrsky%optical_props,lw_Ds) + call check_error_msg('rrtmgp_lw_main_opt_angle', errmsg) + if (len_trim(errmsg) /= 0) then + errflg = 1 + return + end if + errmsg = rte_lw( & + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_clrsky%fluxes, & ! OUT - Fluxes + lw_Ds = lw_Ds) + call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + return + end if else - call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky%fluxes)) ! OUT - Fluxes + errmsg = rte_lw( & + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_clrsky%fluxes) ! OUT - Fluxes + call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + return + end if end if endif end if @@ -127,96 +149,136 @@ subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, ! Include LW cloud-scattering? if (doGP_lwscat) then ! Increment - call check_error_msg('rrtmgp_lw_main_increment_clrsky_to_clouds',& - lw_optical_props_clrsky%optical_props%increment(lw_optical_props_clouds%optical_props)) + errmsg = lw_optical_props_clrsky%optical_props%increment(lw_optical_props_clouds%optical_props) + call check_error_msg('rrtmgp_lw_main_increment_clrsky_to_clouds', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + return + end if if (use_LW_jacobian) then if (nGauss_angles .gt. 1) then ! Compute LW Jacobians; use Gaussian angles - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & - lw_optical_props_clouds%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature - flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + errmsg = rte_lw( & + lw_optical_props_clouds%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky%fluxes, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature + flux_up_Jac = fluxlwUP_jac) ! OUT - surface temperature flux (upward) Jacobian (W m-2 K-1) + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + end if else ! Compute LW Jacobians; don't use Gaussian angles - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & - lw_optical_props_clouds%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + errmsg = rte_lw( & + lw_optical_props_clouds%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky%fluxes, & ! OUT - Fluxes + flux_up_Jac = fluxlwUP_jac) ! OUT - surface temperature flux (upward) Jacobian (W m-2 K-1) + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + end if end if else if (nGauss_angles .gt. 1) then ! Compute LW Jacobians; use Gaussian angles ! Don't compute LW Jacobians; use Gaussian angles - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & - lw_optical_props_clouds%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + errmsg = rte_lw( & + lw_optical_props_clouds%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky%fluxes, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles) ! IN - Number of angles in Gaussian quadrature + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + end if else ! Don't compute LW Jacobians; don't use Gaussian angles - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( & - lw_optical_props_clouds%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes)) ! OUT - Fluxes + errmsg = rte_lw( & + lw_optical_props_clouds%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky%fluxes) ! OUT - Fluxes + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + end if end if end if ! No scattering in LW clouds. else ! Increment - call check_error_msg('rrtmgp_lw_main_increment_clouds_to_clrsky', & - lw_optical_props_clouds%optical_props%increment(lw_optical_props_clrsky%optical_props)) + errmsg = lw_optical_props_clouds%optical_props%increment(lw_optical_props_clrsky%optical_props) + call check_error_msg('rrtmgp_lw_main_increment_clouds_to_clrsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + return + end if if (use_LW_jacobian) then if (nGauss_angles .gt. 1) then ! Compute LW Jacobians; use Gaussian angles - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature - flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + errmsg = rte_lw( & + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky%fluxes, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature + flux_up_Jac = fluxlwUP_jac) ! OUT - surface temperature flux (upward) Jacobian (W m-2 K-1) + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + end if else ! Compute LW Jacobians; don't use Gaussian angles - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - flux_up_Jac = fluxlwUP_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K) + errmsg = rte_lw( & + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky%fluxes, & ! OUT - Fluxes + flux_up_Jac = fluxlwUP_jac) ! OUT - surface temperature flux (upward) Jacobian (W m-2 K-1) + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + end if end if else if (nGauss_angles .gt. 1) then ! Don't compute LW Jacobians; use Gaussian angles - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles)) ! IN - Number of angles in Gaussian quadrature + errmsg = rte_lw( & + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky%fluxes, & ! OUT - Fluxes + n_gauss_angles = nGauss_angles) ! IN - Number of angles in Gaussian quadrature + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) + if (len_trim(errmsg) =/ 0) then + errflg = 1 + end if else ! Don't compute LW Jacobians; don't use Gaussian angles - call check_error_msg('rrtmgp_lw_rte_run',rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - veritcal ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes)) ! OUT - Fluxes + errmsg = rte_lw( & + lw_optical_props_clrsky%optical_props, & ! IN - optical-properties + top_at_1, & ! IN - vertical ordering flag + sources%sources, & ! IN - source function + sfc_emiss_byband, & ! IN - surface emissivity in each LW band + flux_allsky%fluxes) ! OUT - Fluxes + call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) + if (len_trim(errmsg) /= 0) then + errflg = 1 + end if end if end if end if diff --git a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 index b243a46300..8c2169404a 100644 --- a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 +++ b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 @@ -28,8 +28,8 @@ module rrtmgp_lw_mcica_subcol_gen ! !---------------------------------------------------------------------------------------- -use machine, only: kind_phys -use shr_RandNum_mod, only: ShrKissRandGen +use machine, only: kind_phys +use shr_RandNum_mod, only: ShrKissRandGen use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp use ccpp_optical_props, only: ty_optical_props_1scl_ccpp @@ -47,7 +47,7 @@ module rrtmgp_lw_mcica_subcol_gen !> \section arg_table_rrtmgp_lw_mcica_subcol_gen_run Argument Table !! \htmlinclude rrtmgp_lw_mcica_subcol_gen_run.html subroutine rrtmgp_lw_mcica_subcol_gen_run( & - ktoprad, kdist, nbnd, ngpt, ncol, pver, nver, & + dolw, ktoprad, kdist, nbnd, ngpt, ncol, pver, nver, & changeseed, pmid, cldfrac, tauc, cloud_lw, & errmsg, errflg ) @@ -60,21 +60,22 @@ subroutine rrtmgp_lw_mcica_subcol_gen_run( & ! number of subcolumns ! arguments - class(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist ! spectral information - integer, intent(in) :: ktoprad - 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) :: pver ! total number of layers - 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(kind_phys), dimension(:,:), intent(in) :: pmid ! layer pressures (Pa) - real(kind_phys), dimension(:,:), intent(in) :: cldfrac ! layer cloud fraction - real(kind_phys), dimension(:,:,:), intent(in) :: tauc ! cloud optical depth - type(ty_optical_props_1scl_ccpp), intent(inout) :: cloud_lw - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + class(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist ! Gas optics object + logical, intent(in) :: dolw ! Flag for whether to perform longwave calculation + integer, intent(in) :: ktoprad ! Index in RRTMGP array corresponding to top layer or interface of CAM arrays + 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) :: pver ! Number of model layers + integer, intent(in) :: nver ! Number of layers in radiation calculation + integer, intent(in) :: changeseed ! If the subcolumn generator is called multiple times, + ! permute the seed between each call. + real(kind_phys), dimension(:,:), intent(in) :: pmid ! Layer pressures at midpoints (Pa) + real(kind_phys), dimension(:,:), intent(in) :: cldfrac ! Layer cloud fraction + real(kind_phys), dimension(:,:,:), intent(in) :: tauc ! Cloud optical depth + type(ty_optical_props_1scl_ccpp), intent(inout) :: cloud_lw ! Cloud optics object + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! Local variables @@ -97,6 +98,11 @@ subroutine rrtmgp_lw_mcica_subcol_gen_run( & errflg = 0 errmsg = '' + ! If we're not doing longwave this timestep, no need to proceed + if (.not. dolw) then + return + end if + ! clip cloud fraction cldf(:,:) = cldfrac(:ncol,:) where (cldf(:,:) < cldmin) diff --git a/src/physics/rrtmgp/rrtmgp_post.F90 b/src/physics/rrtmgp/rrtmgp_post.F90 index e943f851a2..cb416be841 100644 --- a/src/physics/rrtmgp/rrtmgp_post.F90 +++ b/src/physics/rrtmgp/rrtmgp_post.F90 @@ -14,22 +14,22 @@ module rrtmgp_post !! subroutine rrtmgp_post_run(ncol, qrs, qrl, fsns, pdel, atm_optics_sw, cloud_sw, aer_sw, & fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, netsw, errmsg, errflg) - integer, intent(in) :: ncol - real(kind_phys), dimension(:,:), intent(in) :: pdel - real(kind_phys), dimension(:), intent(in) :: fsns - real(kind_phys), dimension(:,:), intent(inout) :: qrs - real(kind_phys), dimension(:,:), intent(inout) :: qrl - type(ty_optical_props_2str_ccpp), intent(inout) :: atm_optics_sw - type(ty_optical_props_1scl_ccpp), intent(inout) :: aer_lw - type(ty_optical_props_2str_ccpp), intent(inout) :: aer_sw - type(ty_optical_props_1scl_ccpp), intent(inout) :: cloud_lw - type(ty_optical_props_2str_ccpp), intent(inout) :: cloud_sw - type(ty_fluxes_broadband_ccpp), intent(inout) :: fswc - type(ty_fluxes_broadband_ccpp), intent(inout) :: flwc - type(ty_fluxes_byband_ccpp), intent(inout) :: fsw - type(ty_fluxes_byband_ccpp), intent(inout) :: flw - type(ty_source_func_lw_ccpp), intent(inout) :: sources_lw - real(kind_phys), dimension(:), intent(out) :: netsw + integer, intent(in) :: ncol ! Number of columns + real(kind_phys), dimension(:,:), intent(in) :: pdel ! Layer thickness [Pa] + real(kind_phys), dimension(:), intent(in) :: fsns ! Surface net shortwave flux [W m-2] + real(kind_phys), dimension(:,:), intent(inout) :: qrs ! Shortwave heating rate [J kg-1 s-1] + real(kind_phys), dimension(:,:), intent(inout) :: qrl ! Longwave heating rate [J kg-1 s-1] + type(ty_optical_props_2str_ccpp), intent(inout) :: atm_optics_sw ! Atmosphere optical properties object (shortwave) + type(ty_optical_props_1scl_ccpp), intent(inout) :: aer_lw ! Aerosol optical properties object (longwave) + type(ty_optical_props_2str_ccpp), intent(inout) :: aer_sw ! Aerosol optical properties object (shortwave) + type(ty_optical_props_1scl_ccpp), intent(inout) :: cloud_lw ! Cloud optical properties object (longwave) + type(ty_optical_props_2str_ccpp), intent(inout) :: cloud_sw ! Cloud optical properties object (shortwave) + type(ty_fluxes_broadband_ccpp), intent(inout) :: fswc ! Shortwave clear-sky flux object + type(ty_fluxes_broadband_ccpp), intent(inout) :: flwc ! Longwave clear-sky flux object + type(ty_fluxes_byband_ccpp), intent(inout) :: fsw ! Shortwave all-sky flux object + type(ty_fluxes_byband_ccpp), intent(inout) :: flw ! Longwave all-sky flux object + type(ty_source_func_lw_ccpp), intent(inout) :: sources_lw ! Longwave sources object + real(kind_phys), dimension(:), intent(out) :: netsw ! Net shortwave flux to be sent to coupler [W m-2] character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/src/physics/rrtmgp/rrtmgp_pre.F90 b/src/physics/rrtmgp/rrtmgp_pre.F90 index 8c72d0b6fa..2a19da1a14 100644 --- a/src/physics/rrtmgp/rrtmgp_pre.F90 +++ b/src/physics/rrtmgp/rrtmgp_pre.F90 @@ -1,13 +1,44 @@ module rrtmgp_pre - use ccpp_kinds, only: kind_phys - use ccpp_fluxes, only: ty_fluxes_broadband_ccpp - use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp + use ccpp_kinds, only: kind_phys + use ccpp_fluxes, only: ty_fluxes_broadband_ccpp + use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp + use atmos_phys_string_utils, only: to_lower + public :: rrtmgp_pre_init public :: rrtmgp_pre_run public :: radiation_do_ccpp CONTAINS +!> \section arg_table_rrtmgp_pre_init Argument Table +!! \htmlinclude rrtmgp_pre_init.html +!! + subroutine rrtmgp_pre_init(nradgas, gaslist, available_gases, gaslist_lc, errmsg, errflg) + integer, intent(in) :: nradgas ! Number of radiatively active gases + character(len=*), intent(in) :: gaslist ! List of radiatively active gases + type(ty_gas_concentrations_ccpp), intent(inout) :: available_gases ! Gas concentrations object + character(len=*), intent(out) :: gaslist_lc ! Lowercase verison of radiatively active gas list + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Set error variables + errmsg = '' + errflg = 0 + + ! Create lowercase version of the gaslist for RRTMGP. The ty_gas_concs_ccpp 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%gas_concs%init(gaslist_lc) + if (len_trim(errmsg) /= 0) then + errflg = 1 + end if + + end subroutine rrtmgp_pre_init + !> \section arg_table_rrtmgp_pre_run Argument Table !! \htmlinclude rrtmgp_pre_run.html !! @@ -16,31 +47,31 @@ subroutine rrtmgp_pre_run(coszrs, nstep, dtime, iradsw, iradlw, irad_always, nco nswbands, spectralflux, fsw, fswc, flw, flwc, errmsg, errflg) use time_manager, only: get_curr_calday ! Inputs - real(kind_phys), dimension(:), intent(in) :: coszrs - integer, intent(in) :: dtime - integer, intent(in) :: nstep - integer, intent(in) :: iradsw - integer, intent(in) :: iradlw - integer, intent(in) :: irad_always - integer, intent(in) :: ncol - integer, intent(in) :: nlay - integer, intent(in) :: nlwbands - integer, intent(in) :: nswbands - logical, intent(in) :: spectralflux + real(kind_phys), dimension(:), intent(in) :: coszrs ! Cosine solar zenith angle + integer, intent(in) :: dtime ! Timestep size [s] + integer, intent(in) :: nstep ! Timestep number + integer, intent(in) :: iradsw ! Freq. of shortwave radiation calc in time steps (positive) or hours (negative) + integer, intent(in) :: iradlw ! Freq. of longwave radiation calc in time steps (positive) or hours (negative) + integer, intent(in) :: irad_always ! Number of time steps to execute radiation continuously + integer, intent(in) :: ncol ! Number of columns + integer, intent(in) :: nlay ! Number of vertical layers + integer, intent(in) :: nlwbands ! Number of longwave bands + integer, intent(in) :: nswbands ! Number of shortwave bands + logical, intent(in) :: spectralflux ! Flag to calculate fluxes (up and down) per band ! Outputs - class(ty_fluxes_broadband_ccpp), intent(out) :: fswc - class(ty_fluxes_byband_ccpp), intent(out) :: fsw - class(ty_fluxes_broadband_ccpp), intent(out) :: flwc - class(ty_fluxes_byband_ccpp), intent(out) :: flw - integer, intent(out) :: nday - integer, intent(out) :: nnite - real(kind_phys), intent(out) :: nextsw_cday - integer, dimension(:), intent(out) :: idxday - integer, dimension(:), intent(out) :: idxnite - logical, intent(out) :: dosw - logical, intent(out) :: dolw - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + class(ty_fluxes_broadband_ccpp), intent(out) :: fswc ! Clear-sky shortwave flux object + class(ty_fluxes_byband_ccpp), intent(out) :: fsw ! All-sky shortwave flux object + class(ty_fluxes_broadband_ccpp), intent(out) :: flwc ! Clear-sky longwave flux object + class(ty_fluxes_byband_ccpp), intent(out) :: flw ! All-sky longwave flux object + integer, intent(out) :: nday ! Number of daylight columns + integer, intent(out) :: nnite ! Number of nighttime columns + real(kind_phys), intent(out) :: nextsw_cday ! The next calendar day during which radiation calculation will be performed + integer, dimension(:), intent(out) :: idxday ! Indices of daylight columns + integer, dimension(:), intent(out) :: idxnite ! Indices of nighttime columns + logical, intent(out) :: dosw ! Flag to do shortwave calculation + logical, intent(out) :: dolw ! Flag to do longwave calculation + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg ! Local variables integer :: idx From 727c0f1cd872df3c0d3a15f304c5c363a65430a4 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Thu, 3 Apr 2025 17:08:51 -0600 Subject: [PATCH 10/17] move ccppized schemes to atmospheric_physics; fix indexing issues; clean-up cesm-log logging; add rrtmgp paths to configure --- .gitmodules | 4 +- bld/configure | 3 + src/physics/cam/cloud_rad_props.F90 | 50 +- src/physics/rrtmg/radiation.F90 | 12 +- .../rrtmgp/atmos_phys_string_utils.F90 | 58 -- src/physics/rrtmgp/calculate_net_heating.F90 | 69 -- src/physics/rrtmgp/ccpp_fluxes.F90 | 12 - src/physics/rrtmgp/ccpp_fluxes.meta | 7 - src/physics/rrtmgp/ccpp_fluxes_byband.F90 | 12 - src/physics/rrtmgp/ccpp_fluxes_byband.meta | 7 - .../rrtmgp/ccpp_gas_concentrations.F90 | 11 - .../rrtmgp/ccpp_gas_concentrations.meta | 7 - src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 | 11 - .../rrtmgp/ccpp_gas_optics_rrtmgp.meta | 7 - src/physics/rrtmgp/ccpp_optical_props.F90 | 19 - src/physics/rrtmgp/ccpp_optical_props.meta | 15 - src/physics/rrtmgp/ccpp_source_functions.F90 | 11 - src/physics/rrtmgp/ccpp_source_functions.meta | 7 - src/physics/rrtmgp/radiation.F90 | 127 ++-- src/physics/rrtmgp/radiation_tools.F90 | 98 --- src/physics/rrtmgp/radiation_utils.F90 | 203 ------ .../rrtmgp_dry_static_energy_tendency.F90 | 63 -- src/physics/rrtmgp/rrtmgp_inputs.F90 | 652 ------------------ src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 | 463 ------------- src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 | 89 --- .../rrtmgp/rrtmgp_lw_gas_optics_data.F90 | 99 --- .../rrtmgp/rrtmgp_lw_gas_optics_pre.F90 | 180 ----- src/physics/rrtmgp/rrtmgp_lw_main.F90 | 287 -------- .../rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 | 195 ------ src/physics/rrtmgp/rrtmgp_post.F90 | 116 ---- src/physics/rrtmgp/rrtmgp_pre.F90 | 386 ----------- 31 files changed, 126 insertions(+), 3154 deletions(-) delete mode 100644 src/physics/rrtmgp/atmos_phys_string_utils.F90 delete mode 100644 src/physics/rrtmgp/calculate_net_heating.F90 delete mode 100644 src/physics/rrtmgp/ccpp_fluxes.F90 delete mode 100644 src/physics/rrtmgp/ccpp_fluxes.meta delete mode 100644 src/physics/rrtmgp/ccpp_fluxes_byband.F90 delete mode 100644 src/physics/rrtmgp/ccpp_fluxes_byband.meta delete mode 100644 src/physics/rrtmgp/ccpp_gas_concentrations.F90 delete mode 100644 src/physics/rrtmgp/ccpp_gas_concentrations.meta delete mode 100644 src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 delete mode 100644 src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.meta delete mode 100644 src/physics/rrtmgp/ccpp_optical_props.F90 delete mode 100644 src/physics/rrtmgp/ccpp_optical_props.meta delete mode 100644 src/physics/rrtmgp/ccpp_source_functions.F90 delete mode 100644 src/physics/rrtmgp/ccpp_source_functions.meta delete mode 100644 src/physics/rrtmgp/radiation_tools.F90 delete mode 100644 src/physics/rrtmgp/radiation_utils.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_inputs.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_lw_main.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_post.F90 delete mode 100644 src/physics/rrtmgp/rrtmgp_pre.F90 diff --git a/.gitmodules b/.gitmodules index 03cbcece4c..79a74c41a2 100644 --- a/.gitmodules +++ b/.gitmodules @@ -35,8 +35,8 @@ [submodule "atmos_phys"] path = src/atmos_phys - url = https://github.com/ESCOMP/atmospheric_physics - fxtag = atmos_phys0_10_001 + url = https://github.com/peverwhee/atmospheric_physics + fxtag = 12c79730f280e7c5427743c706255ff2820df64e fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics diff --git a/bld/configure b/bld/configure index b03786a83a..7543b9fcdc 100755 --- a/bld/configure +++ b/bld/configure @@ -2144,6 +2144,8 @@ sub write_filepath } print $fh "$camsrcdir/src/physics/rrtmgp/ext/rrtmgp-kernels\n"; print $fh "$camsrcdir/src/physics/rrtmgp/ext/rte-kernels\n"; + print $fh "$camsrcdir/src/atmos_phys/schemes/rrtmgp\n"; + print $fh "$camsrcdir/src/atmos_phys/schemes/rrtmgp/objects\n"; } if ($clubb_sgs) { @@ -2174,6 +2176,7 @@ sub write_filepath print $fh "$camsrcdir/src/atmos_phys/schemes/dry_adiabatic_adjust\n"; print $fh "$camsrcdir/src/atmos_phys/schemes/check_energy\n"; print $fh "$camsrcdir/src/atmos_phys/schemes/hack_shallow\n"; + print $fh "$camsrcdir/src/atmos_phys/schemes/rrtmgp/utils\n"; print $fh "$camsrcdir/src/atmos_phys/schemes/utilities\n"; print $fh "$camsrcdir/src/atmos_phys/schemes/cloud_fraction\n"; diff --git a/src/physics/cam/cloud_rad_props.F90 b/src/physics/cam/cloud_rad_props.F90 index b854ea5900..894f4a1356 100644 --- a/src/physics/cam/cloud_rad_props.F90 +++ b/src/physics/cam/cloud_rad_props.F90 @@ -78,16 +78,25 @@ module cloud_rad_props contains !============================================================================== -subroutine cloud_rad_props_init() - +subroutine cloud_rad_props_init(nmu_out, nlambda_out, n_g_d_out, & + abs_lw_liq_out, abs_lw_ice_out, g_mu_out, g_lambda_out, & + g_d_eff_out, tiny_out) use netcdf use spmd_utils, only: masterproc use ioFileMod, only: getfil use error_messages, only: handle_ncerr - use rrtmgp_lw_cloud_optics, only: rrtmgp_lw_cloud_optics_init #if ( defined SPMD ) use mpishorthand #endif + integer, intent(out) :: nmu_out + integer, intent(out) :: nlambda_out + integer, intent(out) :: n_g_d_out + real(r8), allocatable, intent(out) :: abs_lw_liq_out(:,:,:) + real(r8), allocatable, intent(out) :: abs_lw_ice_out(:,:) + real(r8), allocatable, intent(out) :: g_mu_out(:) + real(r8), allocatable, intent(out) :: g_lambda_out(:,:) + real(r8), allocatable, intent(out) :: g_d_eff_out(:) + real(r8), intent(out) :: tiny_out character(len=256) :: liquidfile character(len=256) :: icefile @@ -281,13 +290,36 @@ subroutine cloud_rad_props_init() call mpibcast(abs_lw_ice, n_g_d*nlwbands, mpir8, 0, mpicom, ierr) #endif - ! Initialize ccpp modules - call rrtmgp_lw_cloud_optics_init(nmu, nlambda, n_g_d, & - abs_lw_liq, abs_lw_ice, nlwbands, g_mu, g_lambda, & - g_d_eff, tiny, errmsg, err) - if (err /= 0) then - call endrun(sub//': rrtmgp_lw_cloud_optics_init failed: '//errmsg) + ! Set output variables + tiny_out = tiny + nmu_out = nmu + nlambda_out = nlambda + n_g_d_out = n_g_d + allocate(abs_lw_liq_out(nmu,nlambda,nlwbands), stat=ierr, errmsg=errmsg) + if (ierr /= 0) then + call endrun(sub//': Failed to allocate abs_lw_liq_out - message: '//errmsg) + end if + abs_lw_liq_out = abs_lw_liq + allocate(abs_lw_ice_out(n_g_d,nlwbands), stat=ierr, errmsg=errmsg) + if (ierr /= 0) then + call endrun(sub//': Failed to allocate abs_lw_ice_out - message: '//errmsg) + end if + abs_lw_ice_out = abs_lw_ice + allocate(g_mu_out(nmu), stat=ierr, errmsg=errmsg) + if (ierr /= 0) then + call endrun(sub//': Failed to allocate g_mu_out - message: '//errmsg) + end if + g_mu_out = g_mu + allocate(g_lambda_out(nmu,nlambda), stat=ierr, errmsg=errmsg) + if (ierr /= 0) then + call endrun(sub//': Failed to allocate g_lambda_out - message: '//errmsg) + end if + g_lambda_out = g_lambda + allocate(g_d_eff_out(n_g_d), stat=ierr, errmsg=errmsg) + if (ierr /= 0) then + call endrun(sub//': Failed to allocate g_d_eff_out - message: '//errmsg) end if + g_d_eff_out = g_d_eff return end subroutine cloud_rad_props_init diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index a4c0cae8f8..ff79c7dd71 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -382,6 +382,15 @@ subroutine radiation_init(pbuf2d) integer :: history_budget_histfile_num ! output history file number for budget fields integer :: err + ! Cloud optics variables + integer :: nmu, n_g_d, nlambda + real(kind=r8), allocatable :: abs_lw_ice(:,:) + real(kind=r8), allocatable :: abs_lw_liq(:,:,:) + real(kind=r8), allocatable :: g_lambda(:,:) + real(kind=r8), allocatable :: g_mu(:) + real(kind=r8), allocatable :: g_d_eff(:) + real(kind=r8) :: tiny + integer :: dtime !----------------------------------------------------------------------- @@ -390,7 +399,8 @@ subroutine radiation_init(pbuf2d) call rad_data_init(pbuf2d) ! initialize output fields for offline driver call radsw_init() call radlw_init() - call cloud_rad_props_init() + call cloud_rad_props_init(nmu, nlambda, n_g_d, abs_lw_liq, abs_lw_ice, & + g_mu, g_lambda, g_d_eff, tiny) cld_idx = pbuf_get_index('CLD') cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=err) diff --git a/src/physics/rrtmgp/atmos_phys_string_utils.F90 b/src/physics/rrtmgp/atmos_phys_string_utils.F90 deleted file mode 100644 index 25be190fd4..0000000000 --- a/src/physics/rrtmgp/atmos_phys_string_utils.F90 +++ /dev/null @@ -1,58 +0,0 @@ -module atmos_phys_string_utils - ! String utils - - implicit none - private - - public :: to_lower - public :: to_upper - -contains - - pure function to_lower(input_string) result(lowercase_string) - character(len=*), intent(in) :: input_string - character(len=*) :: lowercase_string - ! Local variables - - integer :: i ! Index - integer :: aseq ! ascii collating sequence - integer :: upper_to_lower ! integer to convert case - character(len=1) :: ctmp ! Character temporary - !----------------------------------------------------------------------- - upper_to_lower = iachar("a") - iachar("A") - - do i = 1, len(input_string) - ctmp = input_string(i:i) - aseq = iachar(ctmp) - if ( aseq >= iachar("A") .and. aseq <= iachar("Z") ) & - ctmp = achar(aseq + upper_to_lower) - lowercase_string(i:i) = ctmp - end do - - end function to_lower - -!--------------------------------------------------------------------------- -!--------------------------------------------------------------------------- - - pure function to_upper(input_string) result(uppercase_string) - character(len=*), intent(in) :: input_string - character(len=*) :: uppercase_string - - integer :: i ! Index - integer :: aseq ! ascii collating sequence - integer :: lower_to_upper ! integer to convert case - character(len=1) :: ctmp ! Character temporary - !----------------------------------------------------------------------- - lower_to_upper = iachar("A") - iachar("a") - - do i = 1, len(input_string) - ctmp = input_string(i:i) - aseq = iachar(ctmp) - if ( aseq >= iachar("a") .and. aseq <= iachar("z") ) & - ctmp = achar(aseq + lower_to_upper) - uppercase_string(i:i) = ctmp - end do - - end function to_upper - -end module atmos_phys_string_utils diff --git a/src/physics/rrtmgp/calculate_net_heating.F90 b/src/physics/rrtmgp/calculate_net_heating.F90 deleted file mode 100644 index 7c39882b4b..0000000000 --- a/src/physics/rrtmgp/calculate_net_heating.F90 +++ /dev/null @@ -1,69 +0,0 @@ -module calculate_net_heating -! PEVERWHEE - this should go in schemes/rrtmgp/utils -!----------------------------------------------------------------------- -! -! Purpose: Provide an interface to convert shortwave and longwave -! radiative heating terms into net heating. -! -! This module provides a hook to allow incorporating additional -! radiative terms (eUV heating and nonLTE longwave cooling). -! -! Original version: B.A. Boville -!----------------------------------------------------------------------- - -use ccpp_kinds, only: kind_phys - -implicit none -private -save - -! Public interfaces -public :: calculate_net_heating_run - -!=============================================================================== -contains -!=============================================================================== - -!> \section arg_table_calculate_net_heating_run Argument Table -!! \htmlinclude calculate_net_heating_run.html -!! -subroutine calculate_net_heating_run(ncol, rad_heat, qrl, qrs, fsns, fsnt, flns, flnt, & - is_offline_dyn, net_flx, errmsg, errflg) -!----------------------------------------------------------------------- -! Compute net radiative heating from qrs and qrl, and the associated net -! boundary flux. -!----------------------------------------------------------------------- - - ! Arguments - integer, intent(in) :: ncol ! horizontal dimension - real(kind_phys), intent(in) :: qrl(:,:) ! longwave heating [J kg-1 s-1] - real(kind_phys), intent(in) :: qrs(:,:) ! shortwave heating [J kg-1 s-1] - real(kind_phys), intent(in) :: fsns(:) ! Surface solar absorbed flux [W m-2] - real(kind_phys), intent(in) :: fsnt(:) ! Net column abs solar flux at model top [W m-2] - real(kind_phys), intent(in) :: flns(:) ! Srf longwave cooling (up-down) flux [W m-2] - real(kind_phys), intent(in) :: flnt(:) ! Net outgoing lw flux at model top [W m-2] - logical, intent(in) :: is_offline_dyn ! is offline dycore - real(kind_phys), intent(out) :: rad_heat(:,:) ! radiative heating [J kg-1 s-1] - real(kind_phys), intent(out) :: net_flx(:) ! net boundary flux [W m-2] - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - - ! Local variables - integer :: idx - !----------------------------------------------------------------------- - ! Set error variables - errmsg = '' - errflg = 0 - if (.not. is_offline_dyn) then - rad_heat(:ncol,:) = (qrs(:ncol,:) + qrl(:ncol,:)) - end if - - do idx = 1, ncol - net_flx(idx) = fsnt(idx) - fsns(idx) - flnt(idx) + flns(idx) - end do - -end subroutine calculate_net_heating_run - -!================================================================================================ -end module calculate_net_heating diff --git a/src/physics/rrtmgp/ccpp_fluxes.F90 b/src/physics/rrtmgp/ccpp_fluxes.F90 deleted file mode 100644 index d1ab0e3cb3..0000000000 --- a/src/physics/rrtmgp/ccpp_fluxes.F90 +++ /dev/null @@ -1,12 +0,0 @@ -module ccpp_fluxes - ! CCPP wrapper for ty_fluxes DDT from RRTMGP - use mo_fluxes, only: ty_fluxes - use mo_fluxes, only: ty_fluxes_broadband - - !> \section arg_table_ty_fluxes_broadband_ccpp Argument Table - !! \htmlinclude ty_fluxes_broadband_ccpp.html - type, public :: ty_fluxes_broadband_ccpp - type(ty_fluxes_broadband) :: fluxes - end type - -end module ccpp_fluxes diff --git a/src/physics/rrtmgp/ccpp_fluxes.meta b/src/physics/rrtmgp/ccpp_fluxes.meta deleted file mode 100644 index e2e5b6fcc4..0000000000 --- a/src/physics/rrtmgp/ccpp_fluxes.meta +++ /dev/null @@ -1,7 +0,0 @@ -[ccpp-table-properties] - name = ty_fluxes_broadband_ccpp - type = ddt - -[ccpp-arg-table] - name = ty_fluxes_broadband_ccpp - type = ddt diff --git a/src/physics/rrtmgp/ccpp_fluxes_byband.F90 b/src/physics/rrtmgp/ccpp_fluxes_byband.F90 deleted file mode 100644 index 6212efbfaa..0000000000 --- a/src/physics/rrtmgp/ccpp_fluxes_byband.F90 +++ /dev/null @@ -1,12 +0,0 @@ -module ccpp_fluxes_byband - ! CCPP wrapper for ty_fluxes_byband DDT from RRTMGP - use mo_fluxes_byband, only: ty_fluxes_byband - use ccpp_fluxes, only: ty_fluxes_broadband_ccpp - - !> \section arg_table_ty_fluxes_byband_ccpp Argument Table - !! \htmlinclude ty_fluxes_byband_ccpp.html - type, public :: ty_fluxes_byband_ccpp - type(ty_fluxes_byband) :: fluxes - end type - -end module ccpp_fluxes_byband diff --git a/src/physics/rrtmgp/ccpp_fluxes_byband.meta b/src/physics/rrtmgp/ccpp_fluxes_byband.meta deleted file mode 100644 index 6645fc1b16..0000000000 --- a/src/physics/rrtmgp/ccpp_fluxes_byband.meta +++ /dev/null @@ -1,7 +0,0 @@ -[ccpp-table-properties] - name = ty_fluxes_byband_ccpp - type = ddt - -[ccpp-arg-table] - name = ty_fluxes_byband_ccpp - type = ddt diff --git a/src/physics/rrtmgp/ccpp_gas_concentrations.F90 b/src/physics/rrtmgp/ccpp_gas_concentrations.F90 deleted file mode 100644 index 3b3dd96ee2..0000000000 --- a/src/physics/rrtmgp/ccpp_gas_concentrations.F90 +++ /dev/null @@ -1,11 +0,0 @@ -module ccpp_gas_concentrations - ! CCPP wrapper for ty_gas_concs DDT from RRTMGP - use mo_gas_concentrations, only: ty_gas_concs - - !> \section arg_table_ty_gas_concs_ccpp Argument Table - !! \htmlinclude ty_gas_concs_ccpp.html - type, public :: ty_gas_concs_ccpp - type(ty_gas_concs) :: gas_concs - end type - -end module ccpp_gas_concentrations diff --git a/src/physics/rrtmgp/ccpp_gas_concentrations.meta b/src/physics/rrtmgp/ccpp_gas_concentrations.meta deleted file mode 100644 index 1bb7f38640..0000000000 --- a/src/physics/rrtmgp/ccpp_gas_concentrations.meta +++ /dev/null @@ -1,7 +0,0 @@ -[ccpp-table-properties] - name = ty_gas_concs_ccpp - type = ddt - -[ccpp-arg-table] - name = ty_gas_concs_ccpp - type = ddt diff --git a/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 b/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 deleted file mode 100644 index 158da74835..0000000000 --- a/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.F90 +++ /dev/null @@ -1,11 +0,0 @@ -module ccpp_gas_optics_rrtmgp - ! CCPP wrapper for ty_gas_optics_rrtmgp DDT from RRTMGP - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - - !> \section arg_table_ty_gas_optics_rrtmgp_ccpp Argument Table - !! \htmlinclude ty_gas_optics_rrtmgp_ccpp.html - type, public :: ty_gas_optics_rrtmgp_ccpp - type(ty_gas_optics_rrtmgp) :: gas_props - end type - -end module ccpp_gas_optics_rrtmgp diff --git a/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.meta b/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.meta deleted file mode 100644 index 66e0f08dc7..0000000000 --- a/src/physics/rrtmgp/ccpp_gas_optics_rrtmgp.meta +++ /dev/null @@ -1,7 +0,0 @@ -[ccpp-table-properties] - name = ty_gas_optics_rrtmgp_ccpp - type = ddt - -[ccpp-arg-table] - name = ty_gas_optics_rrtmgp_ccpp - type = ddt diff --git a/src/physics/rrtmgp/ccpp_optical_props.F90 b/src/physics/rrtmgp/ccpp_optical_props.F90 deleted file mode 100644 index 94615e1375..0000000000 --- a/src/physics/rrtmgp/ccpp_optical_props.F90 +++ /dev/null @@ -1,19 +0,0 @@ -module ccpp_optical_props - ! CCPP wrapper for ty_optical_props_* DDTs from RRTMGP - use mo_optical_props, only: ty_optical_props_1scl - use mo_optical_props, only: ty_optical_props_2str - use mo_optical_props, only: ty_optical_props_arry - - !> \section arg_table_ty_optical_props_1scl_ccpp Argument Table - !! \htmlinclude ty_optical_props_1scl_ccpp.html - type, public :: ty_optical_props_1scl_ccpp - type(ty_optical_props_1scl) :: optical_props - end type - - !> \section arg_table_ty_optical_props_2str_ccpp Argument Table - !! \htmlinclude ty_optical_props_2str_ccpp.html - type, public :: ty_optical_props_2str_ccpp - type(ty_optical_props_2str) :: optical_props - end type - -end module ccpp_optical_props diff --git a/src/physics/rrtmgp/ccpp_optical_props.meta b/src/physics/rrtmgp/ccpp_optical_props.meta deleted file mode 100644 index 564fbc3c07..0000000000 --- a/src/physics/rrtmgp/ccpp_optical_props.meta +++ /dev/null @@ -1,15 +0,0 @@ -[ccpp-table-properties] - name = ty_optical_props_1scl_ccpp - type = ddt - -[ccpp-arg-table] - name = ty_optical_props_1scl_ccpp - type = ddt - -[ccpp-table-properties] - name = ty_optical_props_2str_ccpp - type = ddt - -[ccpp-arg-table] - name = ty_optical_props_2str_ccpp - type = ddt diff --git a/src/physics/rrtmgp/ccpp_source_functions.F90 b/src/physics/rrtmgp/ccpp_source_functions.F90 deleted file mode 100644 index 56e65e3ded..0000000000 --- a/src/physics/rrtmgp/ccpp_source_functions.F90 +++ /dev/null @@ -1,11 +0,0 @@ -module ccpp_source_functions - ! CCPP wrapper for ty_source_func_lw DDT from RRTMGP - use mo_source_functions, only: ty_source_func_lw - - !> \section arg_table_ty_source_func_lw_ccpp Argument Table - !! \htmlinclude ty_source_func_lw_ccpp.html - type, public :: ty_source_func_lw_ccpp - type(ty_source_func_lw) :: sources - end type - -end module ccpp_source_functions diff --git a/src/physics/rrtmgp/ccpp_source_functions.meta b/src/physics/rrtmgp/ccpp_source_functions.meta deleted file mode 100644 index b0fd2380ea..0000000000 --- a/src/physics/rrtmgp/ccpp_source_functions.meta +++ /dev/null @@ -1,7 +0,0 @@ -[ccpp-table-properties] - name = ty_source_func_lw_ccpp - type = ddt - -[ccpp-arg-table] - name = ty_source_func_lw_ccpp - type = ddt diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index f718314eb4..776223083b 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -411,9 +411,10 @@ end function radiation_do !================================================================================================ subroutine radiation_init(pbuf2d) - use rrtmgp_pre, only: rrtmgp_pre_init - use rrtmgp_inputs, only: rrtmgp_inputs_init - use rrtmgp_inputs_cam, only: rrtmgp_inputs_cam_init + use rrtmgp_pre, only: rrtmgp_pre_init + use rrtmgp_inputs, only: rrtmgp_inputs_init + use rrtmgp_inputs_cam, only: rrtmgp_inputs_cam_init + use rrtmgp_lw_cloud_optics, only: rrtmgp_lw_cloud_optics_init ! Initialize the radiation and cloud optics. ! Add fields to the history buffer. @@ -440,6 +441,15 @@ subroutine radiation_init(pbuf2d) integer :: history_budget_histfile_num ! history file number for budget fields integer :: ierr, istat, errflg + ! Cloud optics variables + integer :: nmu, n_g_d, nlambda + real(kind=r8), allocatable :: abs_lw_ice(:,:) + real(kind=r8), allocatable :: abs_lw_liq(:,:,:) + real(kind=r8), allocatable :: g_lambda(:,:) + real(kind=r8), allocatable :: g_mu(:) + real(kind=r8), allocatable :: g_d_eff(:) + real(kind=r8) :: tiny + integer :: dtime character(len=*), parameter :: sub = 'radiation_init' @@ -448,7 +458,7 @@ subroutine radiation_init(pbuf2d) ! Initialize available_gases object call rrtmgp_pre_init(nradgas, gaslist, available_gases, gaslist_lc, errmsg, errflg) if (errflg /= 0) then - call endrun(sub//': ERROR -'//errmsg) + call endrun(sub//': '//errmsg) end if ! Read RRTMGP coefficients files and initialize kdist objects. @@ -458,15 +468,19 @@ subroutine radiation_init(pbuf2d) ! Set up inputs to RRTMGP call rrtmgp_inputs_init(ktopcam, ktoprad, nlaycam, sw_low_bounds, sw_high_bounds, nswbands, & pref_edge, nlay, pver, pverp, kdist_sw, kdist_lw, qrl_unused, is_first_step(), use_rad_dt_cosz, & - get_step_size(), get_nstep(), iradsw, dt_avg, irad_always, is_first_restart_step(), & + get_step_size(), get_nstep(), iradsw, dt_avg, irad_always, is_first_restart_step(), masterproc, & nlwbands, nradgas, gasnamelength, iulog, idx_sw_diag, idx_nir_diag, idx_uv_diag, & idx_sw_cloudsim, idx_lw_diag, idx_lw_cloudsim, gaslist, nswgpts, nlwgpts, nlayp, & nextsw_cday, get_curr_calday(), band2gpt_sw, errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if - + ! Set up CAM-side RRTMGP inputs - will go away once SW radiation is CCPPized call rrtmgp_inputs_cam_init(ktopcam, ktoprad, idx_sw_diag, idx_nir_diag, idx_uv_diag, idx_sw_cloudsim, idx_lw_diag, & idx_lw_cloudsim) + ! Set radconstants module-level index variables that we're setting in CCPP-ized scheme now call radconstants_init(idx_sw_diag, idx_nir_diag, idx_uv_diag, idx_lw_diag) call rad_solar_var_init(nswbands) @@ -474,7 +488,15 @@ subroutine radiation_init(pbuf2d) ! initialize output fields for offline driver call rad_data_init(pbuf2d) - call cloud_rad_props_init() + call cloud_rad_props_init(nmu, nlambda, n_g_d, abs_lw_liq, abs_lw_ice, & + g_mu, g_lambda, g_d_eff, tiny) + + call rrtmgp_lw_cloud_optics_init(nmu, nlambda, n_g_d, & + abs_lw_liq, abs_lw_ice, nlwbands, g_mu, g_lambda, & + g_d_eff, tiny, errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if cld_idx = pbuf_get_index('CLD') cldfsnow_idx = pbuf_get_index('CLDFSNOW', errcode=ierr) @@ -484,30 +506,11 @@ 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 - ! 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) - ! "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 - ! irad_always = irad_always + nstep - !end if - if (docosp) call cospsimulator_intr_init() allocate(cosp_cnt(begchunk:endchunk), stat=istat) @@ -804,35 +807,36 @@ subroutine radiation_tend( & !----------------------------------------------------------------------- ! 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 rrtmgp_inputs, only: rrtmgp_inputs_run - use rrtmgp_pre, only: rrtmgp_pre_run - use rrtmgp_lw_cloud_optics, only: rrtmgp_lw_cloud_optics_run - use rrtmgp_lw_mcica_subcol_gen, only: rrtmgp_lw_mcica_subcol_gen_run - use rrtmgp_lw_gas_optics_pre, only: rrtmgp_lw_gas_optics_pre_run - use rrtmgp_lw_gas_optics, only: rrtmgp_lw_gas_optics_run - use rrtmgp_lw_main, only: rrtmgp_lw_main_run + 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 + + ! CCPPized schemes + use rrtmgp_inputs, only: rrtmgp_inputs_run + use rrtmgp_pre, only: rrtmgp_pre_run + use rrtmgp_lw_cloud_optics, only: rrtmgp_lw_cloud_optics_run + use rrtmgp_lw_mcica_subcol_gen, only: rrtmgp_lw_mcica_subcol_gen_run + use rrtmgp_lw_gas_optics_pre, only: rrtmgp_lw_gas_optics_pre_run + use rrtmgp_lw_gas_optics, only: rrtmgp_lw_gas_optics_run + use rrtmgp_lw_main, only: rrtmgp_lw_main_run use rrtmgp_dry_static_energy_tendency, only: rrtmgp_dry_static_energy_tendency_run - use rrtmgp_post, only: rrtmgp_post_run + use rrtmgp_post, only: rrtmgp_post_run - use rrtmgp_inputs_cam, only: rrtmgp_get_gas_mmrs, & - rrtmgp_set_aer_lw, rrtmgp_set_gases_sw, rrtmgp_set_cloud_sw, & - rrtmgp_set_aer_sw + use rrtmgp_inputs_cam, only: rrtmgp_get_gas_mmrs, rrtmgp_set_aer_lw, & + rrtmgp_set_gases_sw, rrtmgp_set_cloud_sw, & + rrtmgp_set_aer_sw ! RRTMGP drivers for flux calculations. - use mo_rte_lw, only: rte_lw - use mo_rte_sw, only: rte_sw + use mo_rte_lw, only: rte_lw + use mo_rte_sw, only: rte_sw - use radheat, only: radheat_tend + use radheat, only: radheat_tend - use radiation_data, only: rad_data_write + use radiation_data, only: rad_data_write - use interpolate_data, only: vertinterp - use tropopause, only: tropopause_find_cam, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE - use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps + use interpolate_data, only: vertinterp + use tropopause, only: tropopause_find_cam, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE + use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps ! Arguments @@ -869,6 +873,9 @@ subroutine radiation_tend( & 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) :: cld_lw_abs(nlwbands,state%ncol,pver) ! Cloud absorption optics depth + real(r8) :: snow_lw_abs(nlwbands,state%ncol,pver) ! Snow absorption optics depth + real(r8) :: grau_lw_abs(nlwbands,state%ncol,pver) ! Graupel absorption optics depth real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate real(r8), pointer :: fsds(:) ! Surface solar down flux @@ -1017,6 +1024,8 @@ subroutine radiation_tend( & end do end if + ! Determine if we're running radiation (sw and/or lw) this timestep, + ! find daylight and nighttime indices, and initialize fluxes call rrtmgp_pre_run(coszrs, get_nstep(), get_step_size(), iradsw, iradlw, irad_always, & ncol, nextsw_cday, idxday, nday, idxnite, nnite, dosw, dolw, nlay, nlwbands, & nswbands, spectralflux, fsw, fswc, flw, flwc, errmsg, errflg) @@ -1085,8 +1094,8 @@ subroutine radiation_tend( & call handle_allocate_error(istat, sub, 'gas_mmrs, message: '//errmsg) end if - ! Prepares state variables, daylit columns, albedos for RRTMGP - ! Also calculates modified cloud fraction + ! Prepare state variables, daylit columns, albedos for RRTMGP + ! Also calculate modified cloud fraction call rrtmgp_inputs_run(dosw, dolw, associated(cldfsnow), associated(cldfgrau), & state%pmid, state%pint, state%t, & nday, idxday, cldfprime, coszrs, kdist_sw, t_sfc, & @@ -1236,20 +1245,21 @@ subroutine radiation_tend( & do_graupel = ((icgrauwp_idx > 0) .and. (degrau_idx > 0) .and. associated(cldfgrau)) do_snow = associated(cldfsnow) - ! 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,:,:) - ! Set cloud optical properties in cloud_lw object. call rrtmgp_lw_cloud_optics_run(dolw, ncol, nlay, nlaycam, cld, cldfsnow, cldfgrau, & cldfprime, graupel_in_rad, kdist_lw, cloud_lw, lambda, mu, iclwp, iciwp, & - dei, icswp, des, icgrauwp, degrau, nlwbands, do_snow, & - do_graupel, pver, ktopcam, tauc, cldf, errmsg, errflg) + dei, icswp, des, icgrauwp, degrau, nlwbands, do_snow, do_graupel, pver, & + ktopcam, tauc, cldf, cld_lw_abs, snow_lw_abs, grau_lw_abs, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if + ! Cloud optics for COSP + cld_lw_abs_cloudsim(:ncol,:) = cld_lw_abs(idx_lw_cloudsim,:,:) + snow_lw_abs_cloudsim(:ncol,:) = snow_lw_abs(idx_lw_cloudsim,:,:) + grau_lw_abs_cloudsim(:ncol,:) = grau_lw_abs(idx_lw_cloudsim,:,:) + + ! Create McICA stochastic arrays for lw cloud optical properties call rrtmgp_lw_mcica_subcol_gen_run(dolw, ktoprad, & kdist_lw, nlwbands, nlwgpts, ncol, pver, nlaycam, nlwgpts, & state%pmid, cldf, tauc, cloud_lw, errmsg, errflg ) @@ -1404,6 +1414,7 @@ subroutine radiation_tend( & deallocate(rd) end if + ! Calculate radiative heating (Q*dp), set netsw flux, and do object cleanup call rrtmgp_post_run(ncol, qrs, qrl, fsns, state%pdel, atm_optics_sw, cloud_sw, aer_sw, & fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, cam_out%netsw, errmsg, errflg) if (errflg /= 0) then @@ -2261,7 +2272,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) totplnk, planck_frac, rayl_lower, rayl_upper, optimal_angle_fit, & errmsg, ierr) if (ierr /= 0) then - call endrun(sub//': ERROR message: '//errmsg) + call endrun(sub//': '//errmsg) end if else if (allocated(solar_src_quiet)) then error_msg = kdist%gas_props%load( & diff --git a/src/physics/rrtmgp/radiation_tools.F90 b/src/physics/rrtmgp/radiation_tools.F90 deleted file mode 100644 index e941a34615..0000000000 --- a/src/physics/rrtmgp/radiation_tools.F90 +++ /dev/null @@ -1,98 +0,0 @@ -!>\file radiation_tools.F90 -!! - -!> This module contains tools for radiation -module radiation_tools - use machine, only: & - kind_phys ! Working type - implicit none - - real(kind_phys) :: & - rrtmgp_minP, & ! Minimum pressure allowed in RRTMGP - rrtmgp_minT ! Minimum temperature allowed in RRTMGP -contains - -!> - subroutine cmp_tlev(nCol,nLev,minP,p_lay,t_lay,p_lev,tsfc,t_lev) - ! Inputs - integer, intent(in) :: & - nCol,nLev - real(kind_phys),intent(in) :: & - minP - real(kind_phys),dimension(nCol),intent(in) :: & - tsfc - real(kind_phys),dimension(nCol,nLev),intent(in) :: & - p_lay,t_lay - real(kind_phys),dimension(nCol,nLev+1),intent(in) :: & - p_lev - - ! Outputs - real(kind_phys),dimension(nCol,nLev+1),intent(out) :: & - t_lev - - ! Local - integer :: iCol,iLay, iSFC, iTOA - logical :: top_at_1 - real(kind_phys), dimension(nCol,nLev) :: tem2da, tem2db - - top_at_1 = (p_lev(1,1) .lt. p_lev(1, nLev)) - if (top_at_1) then - iSFC = nLev - iTOA = 1 - else - iSFC = 1 - iTOA = nLev - endif - - if (iTOA .eq. 1) then - tem2da(1:nCol,2:iSFC) = log(p_lay(1:nCol,2:iSFC)) - tem2db(1:nCol,2:iSFC) = log(p_lev(1:nCol,2:iSFC)) - do iCol = 1, nCol - tem2da(iCol,1) = log(p_lay(iCol,1) ) - tem2db(iCol,1) = log(max(minP, p_lev(iCol,1)) ) - tem2db(iCol,iSFC) = log(p_lev(iCol,iSFC) ) - enddo - t_lev(1:NCOL,1) = t_lay(1:NCOL,iTOA) - do iLay = 2, iSFC - do iCol = 1, nCol - t_lev(iCol,iLay) = t_lay(iCol,iLay) + (t_lay(iCol,iLay-1) - t_lay(iCol,iLay))& - * (tem2db(iCol,iLay) - tem2da(iCol,iLay)) & - / (tem2da(iCol,iLay-1) - tem2da(iCol,iLay)) - enddo - enddo - t_lev(1:NCOL,iSFC+1) = tsfc(1:NCOL) - else - tem2da(1:nCol,2:iTOA) = log(p_lay(1:nCol,2:iTOA)) - tem2db(1:nCol,2:iTOA) = log(p_lev(1:nCol,2:iTOA)) - do iCol = 1, nCol - tem2da(iCol,1) = log(p_lay(iCol,1)) - tem2db(iCol,1) = log(p_lev(iCol,1)) - tem2db(iCol,iTOA) = log(max(minP, p_lev(iCol,iTOA)) ) - enddo - - t_lev(1:NCOL,1) = tsfc(1:NCOL) - do iLay = 1, iTOA-1 - do iCol = 1, nCol - t_lev(iCol,iLay+1) = t_lay(iCol,iLay) + (t_lay(iCol,iLay+1) - t_lay(iCol,iLay))& - * (tem2db(iCol,iLay+1) - tem2da(iCol,iLay)) & - / (tem2da(iCol,iLay+1) - tem2da(iCol,iLay)) - enddo - enddo - t_lev(1:NCOL,iTOA+1) = t_lay(1:NCOL,iTOA) - endif - - end subroutine cmp_tlev - -!> - subroutine check_error_msg(routine_name, error_msg) - character(len=*), intent(in) :: & - error_msg, routine_name - - if(error_msg /= "") then - print*,"ERROR("//trim(routine_name)//"): " - print*,trim(error_msg) - return - end if - end subroutine check_error_msg - -end module radiation_tools diff --git a/src/physics/rrtmgp/radiation_utils.F90 b/src/physics/rrtmgp/radiation_utils.F90 deleted file mode 100644 index 2eeb2ff89b..0000000000 --- a/src/physics/rrtmgp/radiation_utils.F90 +++ /dev/null @@ -1,203 +0,0 @@ -module radiation_utils - ! PEVERWHEE - this should go in schemes/rrtmgp/utils - use ccpp_kinds, only: kind_phys - use interpolate_data, only: interp_type, lininterp_init, lininterp, & - extrap_method_bndry - - public :: radiation_utils_init - public :: get_sw_spectral_boundaries_ccpp - public :: get_lw_spectral_boundaries_ccpp - public :: get_mu_lambda_weights_ccpp - - real(kind_phys), allocatable :: wavenumber_low_shortwave(:) - real(kind_phys), allocatable :: wavenumber_high_shortwave(:) - real(kind_phys), allocatable :: wavenumber_low_longwave(:) - real(kind_phys), allocatable :: wavenumber_high_longwave(:) - integer :: nswbands - integer :: nlwbands - logical :: wavenumber_boundaries_set = .false. - -contains - - subroutine radiation_utils_init(nswbands_in, nlwbands_in, low_shortwave, high_shortwave, & - low_longwave, high_longwave, errmsg, errflg) - integer, intent(in) :: nswbands_in ! Number of shortwave bands - integer, intent(in) :: nlwbands_in ! Number of longwave bands - real(kind_phys), intent(in) :: low_shortwave(:) ! Low range values for shortwave bands (cm-1) - real(kind_phys), intent(in) :: high_shortwave(:) ! High range values for shortwave bands (cm-1) - real(kind_phys), intent(in) :: low_longwave(:) ! Low range values for longwave bands (cm-1) - real(kind_phys), intent(in) :: high_longwave(:) ! High range values for longwave bands (cm-1) - integer, intent(out) :: errflg - character(len=*),intent(out) :: errmsg - ! Local variables - character(len=256) :: alloc_errmsg - - errflg = 0 - errmsg = '' - nswbands = nswbands_in - nlwbands = nlwbands_in - allocate(wavenumber_low_shortwave(nswbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg,'(a,a)') 'radiation_utils_init: failed to allocate wavenumber_low_shortwave, message: ', & - alloc_errmsg - end if - allocate(wavenumber_high_shortwave(nswbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg,'(a,a)') 'radiation_utils_init: failed to allocate wavenumber_high_shortwave, message: ', & - alloc_errmsg - end if - allocate(wavenumber_low_longwave(nlwbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg,'(a,a)') 'radiation_utils_init: failed to allocate wavenumber_low_longwave, message: ', & - alloc_errmsg - end if - allocate(wavenumber_high_longwave(nlwbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg,'(a,a)') 'radiation_utils_init: failed to allocate wavenumber_high_longwave, message: ', & - alloc_errmsg - end if - - wavenumber_low_shortwave = low_shortwave - wavenumber_high_shortwave = high_shortwave - wavenumber_low_longwave = low_longwave - wavenumber_high_longwave = high_longwave - - wavenumber_boundaries_set = .true. - - end subroutine radiation_utils_init - -!========================================================================================= - - subroutine get_sw_spectral_boundaries_ccpp(low_boundaries, high_boundaries, units, errmsg, errflg) - - ! provide spectral boundaries of each shortwave band in the units requested - - real(kind_phys), dimension(:), intent(out) :: low_boundaries ! low range bounds for shortwave bands in requested units - real(kind_phys), dimension(:), intent(out) :: high_boundaries ! high range bounds for shortwave bands in requested units - character(*), intent(in) :: units ! requested units - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - character(len=*), parameter :: sub = 'get_sw_spectral_boundaries_ccpp' - !---------------------------------------------------------------------------- - - ! Set error variables - errmsg = '' - errflg = 0 - - if (.not. wavenumber_boundaries_set) then - write(errmsg,'(a,a)') sub, ': ERROR, wavenumber boundaries not set.' - end if - - 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_kind_phys/wavenumber_high_shortwave - high_boundaries = 1.e-2_kind_phys/wavenumber_low_shortwave - case('nm','nanometer','nanometers') - low_boundaries = 1.e7_kind_phys/wavenumber_high_shortwave - high_boundaries = 1.e7_kind_phys/wavenumber_low_shortwave - case('um','micrometer','micrometers','micron','microns') - low_boundaries = 1.e4_kind_phys/wavenumber_high_shortwave - high_boundaries = 1.e4_kind_phys/wavenumber_low_shortwave - case('cm','centimeter','centimeters') - low_boundaries = 1._kind_phys/wavenumber_high_shortwave - high_boundaries = 1._kind_phys/wavenumber_low_shortwave - case default - write(errmsg, '(a,a,a)') sub, ': ERROR, requested spectral units not recognized: ', units - errflg = 1 - end select - - end subroutine get_sw_spectral_boundaries_ccpp - -!========================================================================================= - -subroutine get_lw_spectral_boundaries_ccpp(low_boundaries, high_boundaries, units, errmsg, errflg) - - ! provide spectral boundaries of each longwave band in the units requested - - real(kind_phys), intent(out) :: low_boundaries(nlwbands) ! low range bounds for longwave bands in requested units - real(kind_phys), intent(out) :: high_boundaries(nlwbands) ! high range bounds for longwave bands in requested units - character(*), intent(in) :: units ! requested units - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - character(len=*), parameter :: sub = 'get_lw_spectral_boundaries_ccpp' - !---------------------------------------------------------------------------- - - ! Set error variables - errmsg = '' - errflg = 0 - - if (.not. wavenumber_boundaries_set) then - write(errmsg,'(a,a)') sub, ': ERROR, wavenumber boundaries not set.' - end if - - 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_kind_phys/wavenumber_high_longwave - high_boundaries = 1.e-2_kind_phys/wavenumber_low_longwave - case('nm','nanometer','nanometers') - low_boundaries = 1.e7_kind_phys/wavenumber_high_longwave - high_boundaries = 1.e7_kind_phys/wavenumber_low_longwave - case('um','micrometer','micrometers','micron','microns') - low_boundaries = 1.e4_kind_phys/wavenumber_high_longwave - high_boundaries = 1.e4_kind_phys/wavenumber_low_longwave - case('cm','centimeter','centimeters') - low_boundaries = 1._kind_phys/wavenumber_high_longwave - high_boundaries = 1._kind_phys/wavenumber_low_longwave - case default - write(errmsg, '(a,a,a)') sub, ': ERROR, requested spectral units not recognized: ', units - errflg = 1 - end select - -end subroutine get_lw_spectral_boundaries_ccpp - -!========================================================================================= - -subroutine get_mu_lambda_weights_ccpp(nmu, nlambda, g_mu, g_lambda, lamc, pgam, & - mu_wgts, lambda_wgts, errmsg, errflg) - ! Get mu and lambda interpolation weights - integer, intent(in) :: nmu ! number of mu values - integer, intent(in) :: nlambda ! number of lambda values - real(kind_phys), intent(in) :: g_mu(:) ! mu values - real(kind_phys), intent(in) :: g_lambda(:,:) ! lambda table - real(kind_phys), intent(in) :: lamc ! prognosed value of lambda for cloud - real(kind_phys), 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 ! mu interpolation weights - type(interp_type), intent(out) :: lambda_wgts ! lambda interpolation weights - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: ilambda - real(kind_phys) :: g_lambda_interp(nlambda) - - ! Set error variables - errmsg = '' - errflg = 0 - - ! 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_ccpp - -!========================================================================================= - -end module radiation_utils diff --git a/src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 b/src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 deleted file mode 100644 index c5d7e892f6..0000000000 --- a/src/physics/rrtmgp/rrtmgp_dry_static_energy_tendency.F90 +++ /dev/null @@ -1,63 +0,0 @@ -module rrtmgp_dry_static_energy_tendency -!----------------------------------------------------------------------- -! -! Purpose: Provide an interface to convert shortwave and longwave -! radiative heating terms into net heating. -! -! This module provides a hook to allow incorporating additional -! radiative terms (eUV heating and nonLTE longwave cooling). -! -! Original version: B.A. Boville -!----------------------------------------------------------------------- - -use ccpp_kinds, only: kind_phys - -implicit none -private -save - -! Public interfaces -public :: rrtmgp_dry_static_energy_tendency_run - -!=============================================================================== -contains -!=============================================================================== - -!> \section arg_table_rrtmgp_dry_static_energy_tendency_run Argument Table -!! \htmlinclude rrtmgp_dry_static_energy_tendency_run.html -!! -subroutine rrtmgp_dry_static_energy_tendency_run(ncol, pdel, calc_sw_heat, calc_lw_heat, & - qrs, qrl, errmsg, errflg) -!----------------------------------------------------------------------- -! Compute net radiative heating from qrs and qrl, and the associated net -! boundary flux. -!----------------------------------------------------------------------- - - ! Arguments - integer, intent(in) :: ncol ! Number of columns - real(kind_phys), dimension(:,:), intent(in) :: pdel ! Layer thickness - logical, intent(in) :: calc_sw_heat ! Flag to calculate net shortwave heating - logical, intent(in) :: calc_lw_heat ! Flag to calculate net longwave heating - real(kind_phys), dimension(:,:), intent(inout) :: qrs ! shortwave heating rate (J kg-1 s-1) - real(kind_phys), dimension(:,:), intent(inout) :: qrl ! longwave heating rate (J kg-1 s-1) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - - !----------------------------------------------------------------------- - ! Set error variables - errmsg = '' - errflg = 0 - - if (calc_sw_heat) then - qrs(:ncol,:) = qrs(:ncol,:) / pdel(:ncol,:) - end if - - if (calc_lw_heat) then - qrl(:ncol,:) = qrl(:ncol,:) / pdel(:ncol,:) - end if - -end subroutine rrtmgp_dry_static_energy_tendency_run - -!================================================================================================ -end module rrtmgp_dry_static_energy_tendency diff --git a/src/physics/rrtmgp/rrtmgp_inputs.F90 b/src/physics/rrtmgp/rrtmgp_inputs.F90 deleted file mode 100644 index 2dec2cb420..0000000000 --- a/src/physics/rrtmgp/rrtmgp_inputs.F90 +++ /dev/null @@ -1,652 +0,0 @@ -module rrtmgp_inputs - use machine, only: kind_phys - use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp - use ccpp_optical_props, only: ty_optical_props_1scl_ccpp, ty_optical_props_2str_ccpp - use ccpp_gas_concentrations, only: ty_gas_concs_ccpp - use ccpp_source_functions, only: ty_source_func_lw_ccpp - use string_utils, only: to_lower - use radiation_utils, only: radiation_utils_init, get_sw_spectral_boundaries_ccpp - - implicit none - private - - public :: rrtmgp_inputs_init - public :: rrtmgp_inputs_run - - contains -!> \section arg_table_rrtmgp_inputs_init Argument Table -!! \htmlinclude rrtmgp_inputs_init.html -!! - subroutine rrtmgp_inputs_init(ktopcam, ktoprad, nlaycam, sw_low_bounds, sw_high_bounds, nswbands, & - pref_edge, nlay, pver, pverp, kdist_sw, kdist_lw, qrl, is_first_step, use_rad_dt_cosz, & - timestep_size, nstep, iradsw, dt_avg, irad_always, is_first_restart_step, & - nlwbands, nradgas, gasnamelength, iulog, idx_sw_diag, idx_nir_diag, idx_uv_diag, & - idx_sw_cloudsim, idx_lw_diag, idx_lw_cloudsim, gaslist, nswgpts, nlwgpts, nlayp, & - nextsw_cday, current_cal_day, band2gpt_sw, errmsg, errflg) - - ! Inputs - integer, intent(in) :: nswbands - integer, intent(in) :: nlwbands ! Number of longwave bands - integer, intent(in) :: nradgas ! Number of radiatively active gases - integer, intent(in) :: pverp ! Number of vertical interfaces - integer, intent(in) :: pver ! Number of vertical layers - integer, intent(in) :: iradsw ! Freq. of shortwave radiation calc in time steps (positive) or hours (negative). - integer, intent(in) :: timestep_size ! Timestep size (s) - integer, intent(in) :: nstep ! Current timestep number - integer, intent(in) :: iulog ! Logging unit - integer, intent(in) :: gasnamelength ! Length of all of the gas_list entries - real(kind_phys), intent(in) :: current_cal_day ! Current calendar day - real(kind_phys), dimension(:), intent(in) :: pref_edge ! Reference pressures (interfaces) (Pa) - type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw ! Shortwave gas optics object - type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw ! Longwave gas optics object - logical, intent(in) :: is_first_step ! Flag for whether this is the first timestep (.true. = yes) - logical, intent(in) :: is_first_restart_step ! Flag for whether this is the first restart step (.true. = yes) - logical, intent(in) :: use_rad_dt_cosz - character(len=*), dimension(:), intent(in) :: gaslist - - ! Outputs - integer, intent(out) :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which RRTMGP is active - integer, intent(out) :: ktoprad ! Index in RRTMGP array corresponding to top layer or interface of CAM arrays - integer, intent(out) :: nlaycam ! Number of vertical layers in CAM. Is either equal to nlay - ! or is 1 less than nlay if "extra layer" is used in the radiation calculations - integer, intent(out) :: nlay ! Number of vertical layers in radiation calculation - integer, intent(out) :: nlayp ! Number of vertical interfaces in radiation calculations (nlay + 1) - ! Indices to specific bands for diagnostic output and COSP input - integer, intent(out) :: idx_sw_diag ! Index of band containing 500-nm wave - integer, intent(out) :: idx_nir_diag ! Index of band containing 1000-nm wave - integer, intent(out) :: idx_uv_diag ! Index of band containing 400-nm wave - integer, intent(out) :: idx_sw_cloudsim ! Index of band for shortwave cosp diagnostics - integer, intent(out) :: idx_lw_diag ! Index of band containing 1000-cm-1 wave (H2O window) - integer, intent(out) :: idx_lw_cloudsim ! Index of band for longwave cosp diagnostics - - integer, intent(out) :: nswgpts ! Number of shortwave g-points - integer, intent(out) :: nlwgpts ! Number of longwave g-points - integer, dimension(:,:), intent(out) :: band2gpt_sw ! Array for converting shortwave band limits to g-points - real(kind_phys), intent(out) :: nextsw_cday ! The next calendar day during which the shortwave radiation calculation will be performed - real(kind_phys), dimension(:), intent(out) :: sw_low_bounds ! Lower bounds of shortwave bands - real(kind_phys), dimension(:), intent(out) :: sw_high_bounds ! Upper bounds of shortwave bands - real(kind_phys), dimension(:,:), intent(out) :: qrl ! Longwave radiative heating - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: irad_always ! Number of time steps to execute radiation continuously - real(kind_phys), intent(inout) :: dt_avg ! averaging time interval for zenith angle - - ! Local variables - real(kind_phys), target :: wavenumber_low_shortwave(nswbands) - real(kind_phys), target :: wavenumber_high_shortwave(nswbands) - real(kind_phys), target :: wavenumber_low_longwave(nlwbands) - real(kind_phys), target :: wavenumber_high_longwave(nlwbands) - character(len=gasnamelength) :: gaslist_lc(nradgas) - - ! Set error variables - errflg = 0 - errmsg = '' - - ! 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._kind_phys ) ! pascals (0.01 mbar) - nlayp = 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 - nlaycam = pver - else if (nlay == (pverp-1)) then - ! Special case nlay == (pverp-1) -- topmost interface outside bounds (CAM MT config), treat as if it is ok. - ktopcam = 1 - ktoprad = 2 - nlaycam = pver - nlay = nlay+1 ! reassign the value so later code understands to treat this case like nlay==pverp - write(iulog,*) 'RADIATION_INIT: Special case of 1 model interface at p < 1Pa. Top layer will be INCLUDED in radiation calculation.' - write(iulog,*) 'RADIATION_INIT: nlay = ',nlay, ' same as pverp: ',nlay==pverp - else - ! nlay < pverp. nlay layers are used in radiation calcs, and they are - ! all CAM layers. - ktopcam = pver - nlay + 1 - ktoprad = 1 - nlaycam = nlay - end if - - ! 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, nswbands, nlwbands, idx_sw_diag, idx_nir_diag, & - idx_uv_diag, idx_sw_cloudsim, idx_lw_diag, idx_lw_cloudsim, nswgpts, nlwgpts, & - wavenumber_low_shortwave, wavenumber_high_shortwave, wavenumber_low_longwave, & - wavenumber_high_longwave, band2gpt_sw, errmsg, errflg) - if (errflg /= 0) then - return - end if - - call radiation_utils_init(nswbands, nlwbands, wavenumber_low_shortwave, wavenumber_high_shortwave, & - wavenumber_low_longwave, wavenumber_high_longwave, errmsg, errflg) - if (errflg /= 0) then - return - end if - - ! Initialize the SW band boundaries - call get_sw_spectral_boundaries_ccpp(sw_low_bounds, sw_high_bounds, 'cm^-1', errmsg, errflg) - if (errflg /= 0) then - return - end if - - if (is_first_step) then - qrl = 0._kind_phys - end if - - ! Set the radiation timestep for cosz calculations if requested using - ! the adjusted iradsw value from radiation - if (use_rad_dt_cosz) then - dt_avg = iradsw*timestep_size - end if - - ! "irad_always" is number of time steps to execute radiation continuously from - ! start of initial OR restart run - if (irad_always > 0) then - irad_always = irad_always + nstep - end if - - ! Surface components to get radiation computed today - if (.not. is_first_restart_step) then - nextsw_cday = current_cal_day - end if - - end subroutine rrtmgp_inputs_init - -!> \section arg_table_rrtmgp_inputs_run Argument Table -!! \htmlinclude rrtmgp_inputs_run.html -!! - subroutine rrtmgp_inputs_run(dosw, dolw, snow_associated, graupel_associated, & - pmid, pint, t, nday, idxday, cldfprime, & - 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, lwup, stebol, ncol, ktopcam, ktoprad, & - nswbands, asdir, asdif, sw_low_bounds, sw_high_bounds, & - aldir, aldif, nlay, pverp, pver, cld, cldfsnow, & - cldfgrau, graupel_in_rad, gasnamelength, gaslist, & - gas_concs_lw, aer_lw, atm_optics_lw, kdist_lw, & - sources_lw, aer_sw, atm_optics_sw, gas_concs_sw, & - errmsg, errflg) - ! Inputs - logical, intent(in) :: graupel_in_rad ! Flag to include graupel in radiation calculation - integer, intent(in) :: ncol ! Number of columns - integer, intent(in) :: pver ! Number of vertical layers - integer, intent(in) :: pverp ! Number of vertical interfaces - integer, intent(in) :: nlay ! Number of vertical layers used in radiation calculation - integer, intent(in) :: nswbands ! Number of shortwave bands - integer, intent(in) :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which RRTMGP is active - integer, intent(in) :: ktoprad ! Index in RRTMGP array corresponding to top layer or interface of CAM arrays - integer, intent(in) :: gasnamelength ! Length of gases in gas_list - integer, intent(in) :: nday ! Number of daylight columns - logical, intent(in) :: dosw ! Flag for performing the shortwave calculation - logical, intent(in) :: dolw ! Flag for performing the longwave calculation - logical, intent(in) :: snow_associated ! Flag for whether the cloud snow fraction argument should be used - logical, intent(in) :: graupel_associated ! Flag for whether the cloud graupel fraction argument should be used - integer, dimension(:), intent(in) :: idxday ! Indices of daylight columns - real(kind_phys), dimension(:,:), intent(in) :: pmid ! Air pressure at midpoint (Pa) - real(kind_phys), dimension(:,:), intent(in) :: pint ! Air pressure at interface (Pa) - real(kind_phys), dimension(:,:), intent(in) :: t ! Air temperature (K) - real(kind_phys), dimension(:,:), intent(in) :: cldfsnow ! Cloud fraction of just "snow clouds" - real(kind_phys), dimension(:,:), intent(in) :: cldfgrau ! Cloud fraction of just "graupel clouds" - real(kind_phys), dimension(:,:), intent(in) :: cld ! Cloud fraction (liq+ice) - real(kind_phys), dimension(:), intent(in) :: sw_low_bounds ! Lower bounds for shortwave bands - real(kind_phys), dimension(:), intent(in) :: sw_high_bounds ! Upper bounds for shortwave bands - real(kind_phys), dimension(:), intent(in) :: coszrs ! Cosine of solar senith angle (radians) - real(kind_phys), dimension(:), intent(in) :: lwup ! Longwave up flux (W m-2) - real(kind_phys), dimension(:), intent(in) :: asdir ! Shortwave direct albedo (fraction) - real(kind_phys), dimension(:), intent(in) :: asdif ! Shortwave diffuse albedo (fraction) - real(kind_phys), dimension(:), intent(in) :: aldir ! Longwave direct albedo (fraction) - real(kind_phys), dimension(:), intent(in) :: aldif ! Longwave diffuse albedo (fraction) - real(kind_phys), intent(in) :: stebol ! Stefan-Boltzmann constant (W m-2 K-4) - type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_sw ! Shortwave gas optics object - type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw ! Longwave gas optics object - character(len=*), dimension(:), intent(in) :: gaslist ! Radiatively active gases - ! Outputs - real(kind_phys), dimension(:,:), intent(out) :: t_rad ! Air temperature with radiation indexing (K) - real(kind_phys), dimension(:,:), intent(out) :: pmid_rad ! Midpoint pressure with radiation indexing (Pa) - real(kind_phys), dimension(:,:), intent(out) :: pint_rad ! Interface pressure with radiation indexing (Pa) - real(kind_phys), dimension(:,:), intent(out) :: t_day ! Air temperature of daylight columns (K) - real(kind_phys), dimension(:,:), intent(out) :: pint_day ! Interface pressure of daylight columns (Pa) - real(kind_phys), dimension(:,:), intent(out) :: pmid_day ! Midpoint pressure of daylight columns (Pa) - real(kind_phys), dimension(:,:), intent(out) :: emis_sfc ! Surface emissivity (fraction) - real(kind_phys), dimension(:,:), intent(out) :: alb_dir ! Surface albedo due to UV and VIS direct (fraction) - real(kind_phys), dimension(:,:), intent(out) :: alb_dif ! Surface albedo due to IR diffused (fraction) - real(kind_phys), dimension(:,:), intent(out) :: cldfprime ! modified cloud fraciton - - real(kind_phys), dimension(:), intent(out) :: t_sfc ! Surface temperature (K) - real(kind_phys), dimension(:), intent(out) :: coszrs_day ! Cosine of solar zenith angle for daylight columns (radians) - type(ty_gas_concs_ccpp), intent(out) :: gas_concs_lw ! Gas concentrations object for longwave radiation - type(ty_optical_props_1scl_ccpp), intent(out) :: atm_optics_lw ! Atmosphere optical properties object for longwave radiation - type(ty_optical_props_1scl_ccpp), intent(out) :: aer_lw ! Aerosol optical properties object for longwave radiation - type(ty_source_func_lw_ccpp), intent(out) :: sources_lw ! Longwave sources object for longwave radiation - type(ty_gas_concs_ccpp), intent(out) :: gas_concs_sw ! Gas concentrations object for shortwave radiation - type(ty_optical_props_2str_ccpp), intent(out) :: atm_optics_sw ! Atmosphere optical properties object for shortwave radiation - type(ty_optical_props_2str_ccpp), intent(out) :: aer_sw ! Aerosol optical properties object for shortwave radiation - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - real(kind_phys) :: tref_min - real(kind_phys) :: tref_max - integer :: idx, kdx, iband - character(len=gasnamelength) :: gaslist_lc(size(gaslist)) - - ! Set error variables - errmsg = '' - errflg = 0 - - if (.not. dosw .and. .not. dolw) then - return - end if - - ! RRTMGP set state - t_sfc = sqrt(sqrt(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._kind_phys - - ! Level ordering is the same for both CAM and RRTMGP (top to bottom) - t_rad(:,ktoprad:) = t(:ncol,ktopcam:) - pmid_rad(:,ktoprad:) = pmid(:ncol,ktopcam:) - pint_rad(:,ktoprad:) = pint(:ncol,ktopcam:) - - ! Add extra layer values if needed. - if (nlay == pverp) then - t_rad(:,1) = t(: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_kind_phys - - ! next interface down in LT will always be > 1Pa - ! but in MT we apply adjustment to have it be 1.02 Pa if it was too high - where (pint_rad(:,2) <= pint_rad(:,1)) pint_rad(:,2) = pint_rad(:,1)+0.01_kind_phys - - ! set the highest pmid (in the "extra layer") to the midpoint (guarantees > 1Pa) - pmid_rad(:,1) = pint_rad(:,1) + 0.5_kind_phys * (pint_rad(:,2) - pint_rad(:,1)) - - ! For case of CAM MT, also ensure pint_rad(:,2) > pint_rad(:,1) & pmid_rad(:,2) > max(pmid_rad(:,1), min_pressure) - where (pmid_rad(:,2) <= kdist_sw%gas_props%get_press_min()) pmid_rad(:,2) = pint_rad(:,2) + 0.01_kind_phys - 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_kind_phys - pmid_rad(:,1) = 0.5_kind_phys * (pint_rad(:,1) + pint_rad(:,2)) - end if - - ! Limit temperatures to be within the limits of RRTMGP validity. - tref_min = kdist_sw%gas_props%get_temp_min() - tref_max = kdist_sw%gas_props%get_temp_max() - 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 idx = 1, nday - t_day(idx,:) = t_rad(idxday(idx),:) - pmid_day(idx,:) = pmid_rad(idxday(idx),:) - pint_day(idx,:) = pint_rad(idxday(idx),:) - coszrs_day(idx) = coszrs(idxday(idx)) - end do - ! 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 based on a dividing line of - ! 0.7 micron, or 14286 cm^-1 - do iband = 1,nswbands - if (is_visible(sw_low_bounds(iband)) .and. & - is_visible(sw_high_bounds(iband))) then - - ! Entire band is in the visible - do idx = 1, nday - alb_dir(iband,idx) = asdir(idxday(idx)) - alb_dif(iband,idx) = asdif(idxday(idx)) - end do - - 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 idx = 1, nday - alb_dir(iband,idx) = aldir(idxday(idx)) - alb_dif(iband,idx) = aldif(idxday(idx)) - 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 idx = 1, nday - alb_dir(iband,idx) = 0.5_kind_phys * (aldir(idxday(idx)) + asdir(idxday(idx))) - alb_dif(iband,idx) = 0.5_kind_phys * (aldif(idxday(idx)) + asdif(idxday(idx))) - end do - end if - end do - ! Strictly enforce albedo bounds - where (alb_dir < 0) - alb_dir = 0.0_kind_phys - end where - where (alb_dir > 1) - alb_dir = 1.0_kind_phys - end where - where (alb_dif < 0) - alb_dif = 0.0_kind_phys - end where - where (alb_dif > 1) - alb_dif = 1.0_kind_phys - end where - - ! modified cloud fraction - ! Compute modified cloud fraction, cldfprime. - ! 1. initialize as cld - ! 2. modify for snow. use max(cld, cldfsnow) - ! 3. modify for graupel if graupel_in_rad is true. - ! use max(cldfprime, cldfgrau) - if (snow_associated) then - do kdx = 1, pver - do idx = 1, ncol - cldfprime(idx,kdx) = max(cld(idx,kdx), cldfsnow(idx,kdx)) - end do - end do - else - cldfprime(:ncol,:) = cld(:ncol,:) - end if - - if (graupel_associated .and. graupel_in_rad) then - do kdx = 1, pver - do idx = 1, ncol - cldfprime(idx,kdx) = max(cldfprime(idx,kdx), cldfgrau(idx,kdx)) - end do - end do - end if - - ! Create lowercase version of the gaslist for RRTMGP. The ty_gas_concs_ccpp objects - ! work with CAM's uppercase names, but other objects that get input from the gas - ! concs objects don't work. - do idx = 1, size(gaslist) - gaslist_lc(idx) = to_lower(gaslist(idx)) - end do - - ! If no daylight columns, can't create empty RRTMGP objects - if (dosw .and. nday > 0) then - ! Initialize object for gas concentrations. - errmsg = gas_concs_sw%gas_concs%init(gaslist_lc) - if (len_trim(errmsg) > 0) then - errflg = 1 - return - end if - - ! Initialize object for combined gas + aerosol + cloud optics. - ! Allocates arrays for properties represented on g-points. - errmsg = atm_optics_sw%optical_props%alloc_2str(nday, nlay, kdist_sw%gas_props) - if (len_trim(errmsg) > 0) then - errflg = 1 - return - end if - - ! Initialize object for SW aerosol optics. Allocates arrays - ! for properties represented by band. - errmsg = aer_sw%optical_props%alloc_2str(nday, nlay, kdist_sw%gas_props%get_band_lims_wavenumber()) - if (len_trim(errmsg) > 0) then - errflg = 1 - return - end if - end if - - if (dolw) then - ! Initialize object for gas concentrations - errmsg = gas_concs_lw%gas_concs%init(gaslist_lc) - if (len_trim(errmsg) > 0) then - errflg = 1 - return - end if - - ! Initialize object for combined gas + aerosol + cloud optics. - errmsg = atm_optics_lw%optical_props%alloc_1scl(ncol, nlay, kdist_lw%gas_props) - if (len_trim(errmsg) > 0) then - errflg = 1 - return - end if - - ! Initialize object for LW aerosol optics. - errmsg = aer_lw%optical_props%alloc_1scl(ncol, nlay, kdist_lw%gas_props%get_band_lims_wavenumber()) - if (len_trim(errmsg) > 0) then - errflg = 1 - return - end if - - ! Initialize object for Planck sources. - errmsg = sources_lw%sources%alloc(ncol, nlay, kdist_lw%gas_props) - if (len_trim(errmsg) > 0) then - errflg = 1 - return - end if - end if - - end subroutine rrtmgp_inputs_run - -!========================================================================================= -! HELPER FUNCTIONS ! -!========================================================================================= - subroutine set_wavenumber_bands(kdist_sw, kdist_lw, nswbands, nlwbands, idx_sw_diag, idx_nir_diag, & - idx_uv_diag, idx_sw_cloudsim, idx_lw_diag, idx_lw_cloudsim, nswgpts, nlwgpts, & - wavenumber_low_shortwave, wavenumber_high_shortwave, wavenumber_low_longwave, & - wavenumber_high_longwave, band2gpt_sw, errmsg, errflg) - ! Set the low and high limits of the wavenumber grid for sw and lw. - ! 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_ccpp), intent(in) :: kdist_sw - type(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw - integer, intent(in) :: nswbands - integer, intent(in) :: nlwbands - - integer, intent(out) :: idx_sw_diag - integer, intent(out) :: idx_nir_diag - integer, intent(out) :: idx_uv_diag - integer, intent(out) :: idx_sw_cloudsim - integer, intent(out) :: idx_lw_diag - integer, intent(out) :: idx_lw_cloudsim - integer, intent(out) :: nswgpts - integer, intent(out) :: nlwgpts - integer, dimension(:,:), intent(out) :: band2gpt_sw - real(kind_phys), dimension(:), intent(out) :: wavenumber_low_shortwave - real(kind_phys), dimension(:), intent(out) :: wavenumber_high_shortwave - real(kind_phys), dimension(:), intent(out) :: wavenumber_low_longwave - real(kind_phys), dimension(:), intent(out) :: wavenumber_high_longwave - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: istat - real(kind_phys), allocatable :: values(:,:) - - character(len=*), parameter :: sub = 'set_wavenumber_bands' - !---------------------------------------------------------------------------- - - ! Initialize error variables - errflg = 0 - errmsg = '' - ! Check that number of sw/lw bands in gas optics files matches the parameters. - if (kdist_sw%gas_props%get_nband() /= nswbands) then - write(errmsg,'(a, a,i4,a,i4)') sub, ': ERROR: number of sw bands in file, ', kdist_sw%gas_props%get_nband(), & - ", doesn't match parameter nswbands= ", nswbands - errflg = 1 - return - end if - if (kdist_lw%gas_props%get_nband() /= nlwbands) then - write(errmsg,'(a, a,i4,a,i4)') sub, ': ERROR: number of lw bands in file, ', kdist_lw%gas_props%get_nband(), & - ", doesn't match parameter nlwbands= ", nlwbands - errflg = 1 - return - end if - - nswgpts = kdist_sw%gas_props%get_ngpt() - nlwgpts = kdist_lw%gas_props%get_ngpt() - - ! SW band bounds in cm^-1 - allocate( values(2,nswbands), stat=istat ) - if (istat/=0) then - write(errmsg, '(a,a)') sub, ': ERROR allocating array: values(2,nswbands)' - errflg = 1 - return - end if - values = kdist_sw%gas_props%get_band_lims_wavenumber() - wavenumber_low_shortwave = values(1,:) - wavenumber_high_shortwave = values(2,:) - - ! First and last g-point for each SW band: - band2gpt_sw = kdist_sw%gas_props%get_band_lims_gpoint() - - ! Indices into specific bands - call get_band_index_by_value('sw', 500.0_kind_phys, 'nm', nswbands, & - wavenumber_low_shortwave, wavenumber_high_shortwave, idx_sw_diag, errmsg, errflg) - if (errflg /= 0) then - return - end if - call get_band_index_by_value('sw', 1000.0_kind_phys, 'nm', nswbands, & - wavenumber_low_shortwave, wavenumber_high_shortwave, idx_nir_diag, errmsg, errflg) - if (errflg /= 0) then - return - end if - call get_band_index_by_value('sw', 400._kind_phys, 'nm', nswbands, & - wavenumber_low_shortwave, wavenumber_high_shortwave, idx_uv_diag, errmsg, errflg) - if (errflg /= 0) then - return - end if - call get_band_index_by_value('sw', 0.67_kind_phys, 'micron', nswbands, & - wavenumber_low_shortwave, wavenumber_high_shortwave, idx_sw_cloudsim, errmsg, errflg) - if (errflg /= 0) then - return - end if - - deallocate(values) - - ! LW band bounds in cm^-1 - allocate( values(2,nlwbands), stat=istat ) - if (istat/=0) then - write(errmsg, '(a,a)') sub, ': ERROR allocating array: values(2,nlwbands)' - errflg = 1 - return - end if - values = kdist_lw%gas_props%get_band_lims_wavenumber() - wavenumber_low_longwave = values(1,:) - wavenumber_high_longwave = values(2,:) - - ! Indices into specific bands - call get_band_index_by_value('lw', 1000.0_kind_phys, 'cm^-1', nlwbands, & - wavenumber_low_longwave, wavenumber_high_longwave, idx_lw_diag, errmsg, errflg) - if (errflg /= 0) then - return - end if - call get_band_index_by_value('lw', 10.5_kind_phys, 'micron', nlwbands, & - wavenumber_low_longwave, wavenumber_high_longwave, idx_lw_cloudsim, errmsg, errflg) - if (errflg /= 0) then - return - end if - - end subroutine set_wavenumber_bands - -!========================================================================================= - - subroutine get_band_index_by_value(swlw, targetvalue, units, nbnds, wavenumber_low, & - wavenumber_high, ans, errmsg, errflg) - - ! Find band index for requested wavelength/wavenumber. - - character(len=*), intent(in) :: swlw ! sw or lw bands - real(kind_phys), intent(in) :: targetvalue - character(len=*), intent(in) :: units ! units of targetvalue - integer, intent(in) :: nbnds - real(kind_phys), target, dimension(:), intent(in) :: wavenumber_low - real(kind_phys), target, dimension(:), intent(in) :: wavenumber_high - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(out) :: ans - - ! local - real(kind_phys), pointer, dimension(:) :: lowboundaries, highboundaries - real(kind_phys) :: tgt - integer :: idx - - character(len=*), parameter :: sub = 'get_band_index_by_value' - !---------------------------------------------------------------------------- - - ! Initialize error variables - errflg = 0 - errmsg = '' - lowboundaries => wavenumber_low - highboundaries => wavenumber_high - if (trim(swlw) /= 'sw' .and. trim(swlw) /= 'lw') then - write(errmsg,'(a,a)') 'rrtmgp_inputs: get_band_index_by_value: type of bands not recognized: ', swlw - errflg = 1 - return - end if - - ! 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_kind_phys / (targetvalue * 1.e2_kind_phys) - case('nm','nanometer','nanometers') - tgt = 1.0_kind_phys / (targetvalue * 1.e-7_kind_phys) - case('um','micrometer','micrometers','micron','microns') - tgt = 1.0_kind_phys / (targetvalue * 1.e-4_kind_phys) - case('cm','centimeter','centimeters') - tgt = 1._kind_phys/targetvalue - case default - write(errmsg,'(a,a)') 'rrtmgp_inputs: get_band_index_by_value: units not recognized: ', units - errflg = 1 - end select - - ! now just loop through the array - ans = 0 - do idx = 1,nbnds - if ((tgt > lowboundaries(idx)) .and. (tgt <= highboundaries(idx))) then - ans = idx - exit - end if - end do - - if (ans == 0) then - write(errmsg,'(f10.3,a,a)') targetvalue, ' ', trim(units) - errflg = 1 - end if - - end subroutine get_band_index_by_value - - !========================================================================================= - - 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 - ! This function doesn't distinquish between visible and UV. - - ! wavenumber in inverse cm (cm^-1) - real(kind_phys), intent(in) :: wavenumber - - ! Set threshold between visible and infrared to 0.7 micron, or 14286 cm^-1 - real(kind_phys), parameter :: visible_wavenumber_threshold = 14286._kind_phys ! cm^-1 - - if (wavenumber > visible_wavenumber_threshold) then - is_visible = .true. - else - is_visible = .false. - end if - - end function is_visible - -end module rrtmgp_inputs diff --git a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 deleted file mode 100644 index 61d5168129..0000000000 --- a/src/physics/rrtmgp/rrtmgp_lw_cloud_optics.F90 +++ /dev/null @@ -1,463 +0,0 @@ -! PEVERWHEE - dependencies = interpolate_data -!> \file rrtmgp_lw_cloud_optics.F90 -!! - -!> This module contains two routines: The first initializes data and functions -!! needed to compute the longwave cloud radiative properteis in RRTMGP. The second routine -!! is a ccpp scheme within the "radiation loop", where the shortwave optical properties -!! (optical-depth, single-scattering albedo, asymmetry parameter) are computed for ALL -!! cloud types visible to RRTMGP. -module rrtmgp_lw_cloud_optics - use machine, only: kind_phys - use interpolate_data, only: interp_type, lininterp_init, & - lininterp, extrap_method_bndry, & - lininterp_finish - use radiation_utils, only: get_mu_lambda_weights_ccpp - use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp - use ccpp_optical_props, only: ty_optical_props_1scl_ccpp - - implicit none - public :: rrtmgp_lw_cloud_optics_run - - real(kind_phys), allocatable :: abs_lw_liq(:,:,:) - real(kind_phys), allocatable :: abs_lw_ice(:,:) - real(kind_phys), allocatable :: g_mu(:) - real(kind_phys), allocatable :: g_d_eff(:) - real(kind_phys), allocatable :: g_lambda(:,:) - real(kind_phys) :: tiny - integer :: nmu - integer :: nlambda - integer :: n_g_d - - -contains - - ! ###################################################################################### - ! SUBROUTINE rrtmgp_lw_cloud_optics_init() - ! ###################################################################################### -!> \section arg_table_rrtmgp_lw_cloud_optics_init Argument Table -!! \htmlinclude rrtmgp_lw_cloud_optics_init.html -!! - subroutine rrtmgp_lw_cloud_optics_init(nmu_in, nlambda_in, n_g_d_in, & - abs_lw_liq_in, abs_lw_ice_in, nlwbands, g_mu_in, g_lambda_in, & - g_d_eff_in, tiny_in, errmsg, errflg) - ! Inputs - integer, intent(in) :: nmu_in ! Number of mu samples on grid - integer, intent(in) :: nlambda_in ! Number of lambda scale samples on grid - integer, intent(in) :: n_g_d_in ! Number of radiative effective diameter samples on grid - integer, intent(in) :: nlwbands ! Number of longwave bands - real(kind_phys), dimension(:,:,:), intent(in) :: abs_lw_liq_in ! Longwave mass specific absorption for in-cloud liquid water path - real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice_in ! Longwave mass specific absorption for in-cloud ice water path - real(kind_phys), dimension(:,:), intent(in) :: g_lambda_in ! lambda scale samples on grid - real(kind_phys), dimension(:), intent(in) :: g_mu_in ! Mu samples on grid - real(kind_phys), dimension(:), intent(in) :: g_d_eff_in ! Radiative effective diameter samples on grid - real(kind_phys), intent(in) :: tiny_in ! Definition of what "tiny" means - - ! Outputs - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - character(len=256) :: alloc_errmsg - character(len=*), parameter :: sub = 'rrtmgp_lw_cloud_optics_init' - - ! Set error variables - errmsg = '' - errflg = 0 - - ! Set module-level variables - nmu = nmu_in - nlambda = nlambda_in - n_g_d = n_g_d_in - tiny = tiny_in - ! Allocate module-level-variables - allocate(abs_lw_liq(nmu,nlambda,nlwbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR allocating abs_lw_liq, message: ', alloc_errmsg - return - end if - allocate(abs_lw_ice(n_g_d,nlwbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR allocating abs_lw_ice, message: ', alloc_errmsg - return - end if - allocate(g_mu(nmu), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR allocating g_mu, message: ', alloc_errmsg - return - end if - allocate(g_lambda(nmu,nlambda), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR allocating g_lambda, message: ', alloc_errmsg - return - end if - allocate(g_d_eff(n_g_d), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR allocating g_d_eff, message: ', alloc_errmsg - return - end if - - abs_lw_liq = abs_lw_liq_in - abs_lw_ice = abs_lw_ice_in - g_mu = g_mu_in - g_lambda = g_lambda_in - g_d_eff = g_d_eff_in - - end subroutine rrtmgp_lw_cloud_optics_init - - ! ###################################################################################### - ! SUBROUTINE rrtmgp_lw_cloud_optics_run() - ! ###################################################################################### -!> \section arg_table_rrtmgp_lw_cloud_optics_run Argument Table -!! \htmlinclude rrtmgp_lw_cloud_optics_run.html -!! - subroutine rrtmgp_lw_cloud_optics_run(dolw, ncol, nlay, nlaycam, cld, cldfsnow, cldfgrau, & - cldfprime, graupel_in_rad, kdist_lw, cloud_lw, lamc, pgam, iclwpth, iciwpth, & - dei, icswpth, des, icgrauwpth, degrau, nlwbands, do_snow, & - do_graupel, pver, ktopcam, tauc, cldf, errmsg, errflg) - ! 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 - - ! Inputs - integer, intent(in) :: ncol ! Number of columns - integer, intent(in) :: nlay ! Number of vertical layers in radiation - integer, intent(in) :: nlaycam ! Number of model layers in radiation - integer, intent(in) :: nlwbands ! Number of longwave bands - integer, intent(in) :: pver ! Total number of vertical layers - integer, intent(in) :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which RRTMGP is active - real(kind_phys), dimension(:,:), intent(in) :: cld ! Cloud fraction (liq + ice) - real(kind_phys), dimension(:,:), intent(in) :: cldfsnow ! Cloud fraction of just "snow clouds" - real(kind_phys), dimension(:,:), intent(in) :: cldfgrau ! Cloud fraction of just "graupel clouds" - real(kind_phys), dimension(:,:), intent(in) :: cldfprime ! Modified cloud fraction - real(kind_phys), dimension(:,:), intent(in) :: lamc ! Prognosed value of lambda for cloud - real(kind_phys), dimension(:,:), intent(in) :: pgam ! Prognosed value of mu for cloud - real(kind_phys), dimension(:,:), intent(in) :: iclwpth ! In-cloud liquid water path - real(kind_phys), dimension(:,:), intent(in) :: iciwpth ! In-cloud ice water path - real(kind_phys), dimension(:,:), intent(in) :: icswpth ! In-cloud snow water path - real(kind_phys), dimension(:,:), intent(in) :: icgrauwpth ! In-cloud graupel water path - real(kind_phys), dimension(:,:), intent(in) :: dei ! Mean effective radius for ice cloud - real(kind_phys), dimension(:,:), intent(in) :: des ! Mean effective radius for snow - real(kind_phys), dimension(:,:), intent(in) :: degrau ! Mean effective radius for graupel - logical, intent(in) :: graupel_in_rad ! Flag for whether to include graupel in calculation - logical, intent(in) :: do_snow ! Flag for whether cldfsnow is present - logical, intent(in) :: do_graupel ! Flag for whether cldfgrau is present - logical, intent(in) :: dolw ! Flag for whether to perform longwave calculation - class(ty_gas_optics_rrtmgp_ccpp), intent(in) :: kdist_lw ! Longwave gas optics object - - ! Outputs - type(ty_optical_props_1scl_ccpp), intent(out) :: cloud_lw ! Longwave cloud optics object - real(kind_phys), dimension(:,:), intent(out) :: cldf ! Subset cloud fraction - real(kind_phys), dimension(:,:,:), intent(out) :: tauc ! Cloud optical depth - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: idx, kdx - - ! cloud radiative parameters are "in cloud" not "in cell" - real(kind_phys) :: liq_lw_abs(nlwbands, ncol, pver) ! liquid absorption optics depth (LW) - real(kind_phys) :: ice_lw_abs(nlwbands, ncol, pver) ! ice absorption optics depth (LW) - real(kind_phys) :: cld_lw_abs(nlwbands, ncol, pver) ! cloud absorption optics depth (LW) - real(kind_phys) :: snow_lw_abs(nlwbands, ncol, pver) ! snow absorption optics depth (LW) - real(kind_phys) :: grau_lw_abs(nlwbands, ncol, pver) ! graupel absorption optics depth (LW) - real(kind_phys) :: c_cld_lw_abs(nlwbands, ncol, pver) ! combined cloud absorption optics depth (LW) - - character(len=*), parameter :: sub = 'rrtmgp_lw_cloud_optics_run' - !-------------------------------------------------------------------------------- - - ! Set error variables - errmsg = '' - errflg = 0 - - ! If not doing longwave, no need to proceed - if (.not. dolw) then - return - end if - - ! Combine the cloud optical properties. - - ! gammadist liquid optics - call liquid_cloud_get_rad_props_lw(ncol, pver, nmu, nlambda, nlwbands, lamc, pgam, g_mu, g_lambda, iclwpth, & - abs_lw_liq, liq_lw_abs, errmsg, errflg) - if (errflg /= 0) then - return - end if - ! Mitchell ice optics - call ice_cloud_get_rad_props_lw(ncol, pver, nlwbands, iciwpth, dei, n_g_d, g_d_eff, abs_lw_ice, ice_lw_abs, & - errmsg, errflg) - if (errflg /= 0) then - return - end if - - cld_lw_abs(:,:,:) = liq_lw_abs(:,:,:) + ice_lw_abs(:,:,:) - - if (do_snow) then - ! add in snow - call snow_cloud_get_rad_props_lw(ncol, pver, nlwbands, icswpth, des, n_g_d, g_d_eff, abs_lw_ice, & - snow_lw_abs, errmsg, errflg) - if (errflg /= 0) then - return - end if - do idx = 1, ncol - do kdx = 1, pver - if (cldfprime(idx,kdx) > 0._kind_phys) then - c_cld_lw_abs(:,idx,kdx) = ( cldfsnow(idx,kdx)*snow_lw_abs(:,idx,kdx) & - + cld(idx,kdx)*cld_lw_abs(:,idx,kdx) )/cldfprime(idx,kdx) - else - c_cld_lw_abs(:,idx,kdx) = 0._kind_phys - end if - end do - end do - else - c_cld_lw_abs(:,:,:) = cld_lw_abs(:,:,:) - end if - - ! add in graupel - if (do_graupel .and. graupel_in_rad) then - call grau_cloud_get_rad_props_lw(ncol, pver, nlwbands, icgrauwpth, degrau, n_g_d, g_d_eff, abs_lw_ice, & - grau_lw_abs, errmsg, errflg) - if (errflg /= 0) then - return - end if - do idx = 1, ncol - do kdx = 1, pver - if (cldfprime(idx,kdx) > 0._kind_phys) then - c_cld_lw_abs(:,idx,kdx) = ( cldfgrau(idx,kdx)*grau_lw_abs(:,idx,kdx) & - + cld(idx,kdx)*c_cld_lw_abs(:,idx,kdx) )/cldfprime(idx,kdx) - else - c_cld_lw_abs(:,idx,kdx) = 0._kind_phys - end if - end do - end do - end if - - ! Extract just the layers of CAM where RRTMGP does calculations - - ! Subset "chunk" data so just the number of CAM layers in the - ! radiation calculation are used by MCICA to produce subcolumns - cldf = cldfprime(:, ktopcam:) - tauc = c_cld_lw_abs(:, :, ktopcam:) - - ! Enforce tauc >= 0. - tauc = merge(tauc, 0.0_kind_phys, tauc > 0.0_kind_phys) - - errmsg =cloud_lw%optical_props%alloc_1scl(ncol, nlay, kdist_lw%gas_props) - if (len_trim(errmsg) > 0) then - errflg = 1 - return - end if - - end subroutine rrtmgp_lw_cloud_optics_run - -!============================================================================== - - subroutine liquid_cloud_get_rad_props_lw(ncol, pver, nmu, nlambda, nlwbands, lamc, pgam, & - g_mu, g_lambda, iclwpth, abs_lw_liq, abs_od, errmsg, errflg) - ! Inputs - integer, intent(in) :: ncol - integer, intent(in) :: pver - integer, intent(in) :: nmu - integer, intent(in) :: nlambda - integer, intent(in) :: nlwbands - real(kind_phys), dimension(:,:), intent(in) :: lamc - real(kind_phys), dimension(:,:), intent(in) :: pgam - real(kind_phys), dimension(:,:,:), intent(in) :: abs_lw_liq - real(kind_phys), dimension(:), intent(in) :: g_mu - real(kind_phys), dimension(:,:), intent(in) :: g_lambda - real(kind_phys), dimension(:,:), intent(in) :: iclwpth - ! Outputs - real(kind_phys), dimension(:,:,:), intent(out) :: abs_od - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer lwband, idx, kdx - - ! Set error variables - errflg = 0 - errmsg = '' - - abs_od = 0._kind_phys - - do kdx = 1,pver - do idx = 1,ncol - if(lamc(idx,kdx) > 0._kind_phys) then ! This seems to be the clue for no cloud from microphysics formulation - call gam_liquid_lw(nlwbands, nmu, nlambda, iclwpth(idx,kdx), lamc(idx,kdx), pgam(idx,kdx), abs_lw_liq, & - g_mu, g_lambda, abs_od(1:nlwbands,idx,kdx), errmsg, errflg) - else - abs_od(1:nlwbands,idx,kdx) = 0._kind_phys - endif - enddo - enddo - - end subroutine liquid_cloud_get_rad_props_lw - -!============================================================================== - - subroutine gam_liquid_lw(nlwbands, nmu, nlambda, clwptn, lamc, pgam, abs_lw_liq, g_mu, g_lambda, abs_od, errmsg, errflg) - ! Inputs - integer, intent(in) :: nlwbands - integer, intent(in) :: nmu - integer, intent(in) :: nlambda - real(kind_phys), intent(in) :: clwptn ! cloud water liquid path new (in cloud) (in g/m^2)? - real(kind_phys), intent(in) :: lamc ! prognosed value of lambda for cloud - real(kind_phys), intent(in) :: pgam ! prognosed value of mu for cloud - real(kind_phys), dimension(:,:,:), intent(in) :: abs_lw_liq - real(kind_phys), dimension(:), intent(in) :: g_mu - real(kind_phys), dimension(:,:) , intent(in) :: g_lambda - ! Outputs - real(kind_phys), dimension(:), intent(out) :: abs_od - integer, intent(out) :: errflg - character(len=*), intent(out) :: errmsg - - integer :: lwband ! sw band index - - type(interp_type) :: mu_wgts - type(interp_type) :: lambda_wgts - - if (clwptn < tiny) then - abs_od = 0._kind_phys - return - endif - - call get_mu_lambda_weights_ccpp(nmu, nlambda, g_mu, g_lambda, lamc, pgam, mu_wgts, lambda_wgts, errmsg, errflg) - if (errflg /= 0) then - return - end if - - 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 ice_cloud_get_rad_props_lw(ncol, pver, nlwbands, iciwpth, dei, & - n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) - integer, intent(in) :: ncol - integer, intent(in) :: pver - integer, intent(in) :: n_g_d - integer, intent(in) :: nlwbands - real(kind_phys), dimension(:), intent(in) :: g_d_eff - real(kind_phys), dimension(:,:), intent(in) :: iciwpth - real(kind_phys), dimension(:,:), intent(in) :: dei - real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice - real(kind_phys), dimension(:,:,:), intent(out) :: abs_od - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Set error variables - errflg = 0 - errmsg = '' - - call interpolate_ice_optics_lw(ncol, pver, nlwbands, iciwpth, dei, & - n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) - - end subroutine ice_cloud_get_rad_props_lw - -!============================================================================== - - subroutine snow_cloud_get_rad_props_lw(ncol, pver, nlwbands, icswpth, des, & - n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) - integer, intent(in) :: ncol - integer, intent(in) :: pver - integer, intent(in) :: n_g_d - integer, intent(in) :: nlwbands - real(kind_phys), dimension(:), intent(in) :: g_d_eff - real(kind_phys), dimension(:,:), intent(in) :: icswpth - real(kind_phys), dimension(:,:), intent(in) :: des - real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice - real(kind_phys), dimension(:,:,:), intent(out) :: abs_od - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errflg = 0 - errmsg = '' - - call interpolate_ice_optics_lw(ncol, pver, nlwbands, icswpth, des, & - n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) - - end subroutine snow_cloud_get_rad_props_lw - -!============================================================================== - - subroutine grau_cloud_get_rad_props_lw(ncol, pver, nlwbands, icgrauwpth, degrau, & - n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) - integer, intent(in) :: ncol - integer, intent(in) :: pver - integer, intent(in) :: n_g_d - integer, intent(in) :: nlwbands - real(kind_phys), dimension(:), intent(in) :: g_d_eff - real(kind_phys), dimension(:,:), intent(in) :: icgrauwpth - real(kind_phys), dimension(:,:), intent(in) :: degrau - real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice - real(kind_phys), dimension(:,:,:), intent(out) :: abs_od - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! This does the same thing as ice_cloud_get_rad_props_lw, except with a - ! different water path and effective diameter. - call interpolate_ice_optics_lw(ncol, pver, nlwbands, icgrauwpth, degrau, n_g_d, & - g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) - - end subroutine grau_cloud_get_rad_props_lw - -!============================================================================== - - subroutine interpolate_ice_optics_lw(ncol, pver, nlwbands, iciwpth, dei, & - n_g_d, g_d_eff, abs_lw_ice, abs_od, errmsg, errflg) - - integer, intent(in) :: ncol - integer, intent(in) :: n_g_d - integer, intent(in) :: pver - integer, intent(in) :: nlwbands - real(kind_phys), dimension(:), intent(in) :: g_d_eff - real(kind_phys), dimension(:,:), intent(in) :: iciwpth - real(kind_phys), dimension(:,:), intent(in) :: dei - real(kind_phys), dimension(:,:), intent(in) :: abs_lw_ice - real(kind_phys), dimension(:,:,:), intent(out) :: abs_od - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - type(interp_type) :: dei_wgts - - integer :: idx, kdx, lwband - real(kind_phys) :: absor(nlwbands) - - ! Set error variables - errflg = 0 - errmsg = '' - - do kdx = 1,pver - do idx = 1,ncol - ! if ice water path is too small, OD := 0 - if( iciwpth(idx,kdx) < tiny .or. dei(idx,kdx) == 0._kind_phys) then - abs_od (:,idx,kdx) = 0._kind_phys - else - ! for each cell interpolate to find weights in g_d_eff grid. - call lininterp_init(g_d_eff, n_g_d, dei(idx:idx,kdx), 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(:,idx,kdx) = iciwpth(idx,kdx) * absor - where(abs_od(:,idx,kdx) > 50.0_kind_phys) abs_od(:,idx,kdx) = 50.0_kind_phys - call lininterp_finish(dei_wgts) - endif - enddo - enddo - - end subroutine interpolate_ice_optics_lw - -!============================================================================== - -end module rrtmgp_lw_cloud_optics diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 deleted file mode 100644 index d91afadbf6..0000000000 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics.F90 +++ /dev/null @@ -1,89 +0,0 @@ -!> \file rrtmgp_lw_gas_optics.F90 -!! - -!> This module contains a run routine to compute gas optics during the radiation subcycle -module rrtmgp_lw_gas_optics - use machine, only: kind_phys - use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp - use ccpp_gas_concentrations, only: ty_gas_concs_ccpp - use ccpp_optical_props, only: ty_optical_props_1scl_ccpp - use ccpp_source_functions, only: ty_source_func_lw_ccpp - use radiation_tools, only: check_error_msg - - implicit none - - public :: rrtmgp_lw_gas_optics_run -contains - -!> \section arg_table_rrtmgp_lw_gas_optics_run Argument Table -!! \htmlinclude rrtmgp_lw_gas_optics_run.html -!! - subroutine rrtmgp_lw_gas_optics_run(dolw, iter_num, ncol, rrtmgp_phys_blksz, p_lay, p_lev, t_lay, tsfg, & - gas_concs, lw_optical_props_clrsky, sources, t_lev, include_interface_temp, lw_gas_props, & - errmsg, errflg) - ! Inputs - logical, intent(in) :: dolw !< Flag for whether to perform longwave calculation - logical, intent(in) :: include_interface_temp !< Flag for whether to include interface temperature in calculation - integer, intent(in) :: iter_num !< Subcycle iteration number - integer, intent(in) :: ncol !< Total number of columns - integer, intent(in) :: rrtmgp_phys_blksz !< Number of horizontal points to process at once - real(kind_phys), dimension(:,:), intent(in) :: p_lay !< Air pressure at midpoints [Pa] - real(kind_phys), dimension(:,:), intent(in) :: p_lev !< Air pressure at interfaces [Pa] - real(kind_phys), dimension(:,:), intent(in) :: t_lay !< Air temperature at midpoints [K] - real(kind_phys), dimension(:), intent(in) :: tsfg !< Surface skin temperature [K] - real(kind_phys), dimension(:,:), intent(in) :: t_lev !< Air temperature at interfaces [K] - type(ty_gas_concs_ccpp), intent(in) :: gas_concs !< RRTMGP gas concentrations object - - ! Outputs - type(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clrsky !< Clearsky optical properties - type(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: lw_gas_props !< RRTMGP gas optics object - type(ty_source_func_lw_ccpp), intent(inout) :: sources !< Longwave sources object - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: iCol, iCol2 - - ! Set error variables - errmsg = '' - errflg = 0 - - if (.not. dolw) then - return - end if - - iCol = ((iter_num - 1) * rrtmgp_phys_blksz) + 1 - iCol2= min(iCol + rrtmgp_phys_blksz - 1, ncol) - - if (include_interface_temp) then - errmsg = lw_gas_props%gas_props%gas_optics(& - p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) - tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) - gas_concs%gas_concs, & ! IN - RRTMGP DDT: trace gas volume mixing-ratios - lw_optical_props_clrsky%optical_props, & ! OUT - RRTMGP DDT: longwave optical properties - sources%sources, & ! OUT - RRTMGP DDT: source functions - tlev=t_lev(iCol:iCol2,:)) ! IN - Temperature @ layer-interfaces (K) (optional) - call check_error_msg('rrtmgp_lw_main_gas_optics', errmsg) - if (len_trim(errmsg) /= 0) then - errflg = 1 - end if - else - errmsg = lw_gas_props%gas_props%gas_optics(& - p_lay(iCol:iCol2,:), & ! IN - Pressure @ layer-centers (Pa) - p_lev(iCol:iCol2,:), & ! IN - Pressure @ layer-interfaces (Pa) - t_lay(iCol:iCol2,:), & ! IN - Temperature @ layer-centers (K) - tsfg(iCol:iCol2), & ! IN - Skin-temperature (K) - gas_concs%gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios - lw_optical_props_clrsky%optical_props, & ! OUT - RRTMGP DDT: longwave optical properties - sources%sources) ! OUT - RRTMGP DDT: source functions - call check_error_msg('rrtmgp_lw_main_gas_optics', errmsg) - if (len_trim(errmsg) /= 0) then - errflg = 1 - end if - end if - - end subroutine rrtmgp_lw_gas_optics_run - -end module rrtmgp_lw_gas_optics diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 deleted file mode 100644 index 3de9f2f9ea..0000000000 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_data.F90 +++ /dev/null @@ -1,99 +0,0 @@ -!> \file rrtmgp_lw_gas_optics_data.F90 -!! - -!> This module contains an init routine to initialize the gas optics object -!> with data read in from file on the host side -module rrtmgp_lw_gas_optics_data - use machine, only: kind_phys - use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp - use ccpp_gas_concentrations, only: ty_gas_concs_ccpp - use radiation_tools, only: check_error_msg - - implicit none - - -contains -!> \section arg_table_rrtmgp_lw_gas_optics_data_init Argument Table -!! \htmlinclude rrtmgp_lw_gas_optics_data_init.html -!! - subroutine rrtmgp_lw_gas_optics_data_init(kdist, 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, & - errmsg, errflg) - - ! Inputs - class(ty_gas_concs_ccpp), intent(in) :: available_gases ! Gas concentrations object - character(len=*), dimension(:), intent(in) :: gas_names ! Names of absorbing gases - character(len=*), dimension(:), intent(in) :: gas_minor ! Name of absorbing minor gas - character(len=*), dimension(:), intent(in) :: identifier_minor ! Unique string identifying minor gas - character(len=*), dimension(:), intent(in) :: minor_gases_lower ! Names of minor absorbing gases in lower atmosphere - character(len=*), dimension(:), intent(in) :: minor_gases_upper ! Names of minor absorbing gases in upper atmosphere - character(len=*), dimension(:), intent(in) :: scaling_gas_lower ! Absorption also depends on the concentration of this gas in the lower atmosphere - character(len=*), dimension(:), intent(in) :: scaling_gas_upper ! Absorption also depends on the concentration of this gas in the upper atmosphere - integer, dimension(:,:,:), intent(in) :: key_species ! Key species pair for each band - integer, dimension(:,:), intent(in) :: band2gpt ! Array for converting shortwave band limits to g-points - integer, dimension(:,:), intent(in) :: minor_limits_gpt_lower ! Beginning and ending gpoint for each minor interval in lower atmosphere - integer, dimension(:,:), intent(in) :: minor_limits_gpt_upper ! Beginning and ending gpoint for each minor interval in upper atmosphere - integer, dimension(:), intent(in) :: kminor_start_lower ! Starting index in the [1,nContributors] vector for a contributor given by "minor_gases_lower" - integer, dimension(:), intent(in) :: kminor_start_upper ! Starting index in the [1,nContributors] vector for a contributor given by "minor_gases_upper" - logical, dimension(:), intent(in) :: minor_scales_with_density_lower ! Density scaling is applied to minor absorption coefficients in the lower atmosphere - logical, dimension(:), intent(in) :: scale_by_complement_lower ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) in the lower atmosphere - logical, dimension(:), intent(in) :: minor_scales_with_density_upper ! Density scaling is applied to minor absorption coefficients in the upper atmosphere - logical, dimension(:), intent(in) :: scale_by_complement_upper ! Absorption is scaled by concentration of scaling_gas (F) or its complement (T) in the upper atmosphere - real(kind_phys), dimension(:,:,:,:), intent(in) :: kmajor ! Stored absorption coefficients due to major absorbing gases - real(kind_phys), dimension(:,:,:,:), intent(in) :: planck_frac ! Fraction of band-integrated Planck energy associated with each g-point - real(kind_phys), dimension(:,:,:), intent(in) :: kminor_lower ! Transformed from [nTemp x nEta x nGpt x nAbsorbers] array to [nTemp x nEta x nContributors] array - real(kind_phys), dimension(:,:,:), intent(in) :: kminor_upper ! Transformed from [nTemp x nEta x nGpt x nAbsorbers] array to [nTemp x nEta x nContributors] array - real(kind_phys), dimension(:,:,:), intent(in) :: vmr_ref ! Volume mixing ratios for reference atmosphere - real(kind_phys), dimension(:,:), intent(in) :: band_lims_wavenum ! Beginning and ending wavenumber for each band [cm-1] - real(kind_phys), dimension(:,:), intent(in) :: totplnk ! Integrated Planck function by band - real(kind_phys), dimension(:,:), intent(in) :: optimal_angle_fit ! Coefficients for linear fit used in longwave optimal angle RT calculation - real(kind_phys), dimension(:), intent(in) :: press_ref ! Pressures for reference atmosphere [Pa] - real(kind_phys), dimension(:), intent(in) :: temp_ref ! Temperatures for reference atmosphere [K] - real(kind_phys), intent(in) :: press_ref_trop ! Reference pressure separating the lower and upper atmosphere [Pa] - real(kind_phys), intent(in) :: temp_ref_p ! Standard spectroscopic reference pressure [Pa] - real(kind_phys), intent(in) :: temp_ref_t ! Standard spectroscopic reference temperature [K] - real(kind_phys), dimension(:,:,:), allocatable, intent(in) :: rayl_lower ! Stored coefficients due to rayleigh scattering contribution in lower part of atmosphere - real(kind_phys), dimension(:,:,:), allocatable, intent(in) :: rayl_upper ! Stored coefficients due to rayleigh scattering contribution in upper part of atmosphere - - ! Outputs - class(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: kdist ! RRTMGP gas optics object - character(len=*), intent(out) :: errmsg ! CCPP error message - integer, intent(out) :: errflg ! CCPP error code - - ! Initialize error variables - errmsg = '' - errflg = 0 - - ! Initialize the gas optics object with data. - errmsg = kdist%gas_props%load( & - available_gases%gas_concs, 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) - - if (len_trim(errmsg) > 0) then - errflg = 1 - end if - call check_error_msg('rrtmgp_lw_gas_optics_init_load', errmsg) - - end subroutine rrtmgp_lw_gas_optics_data_init - -end module rrtmgp_lw_gas_optics_data diff --git a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 b/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 deleted file mode 100644 index 9d94d5a05e..0000000000 --- a/src/physics/rrtmgp/rrtmgp_lw_gas_optics_pre.F90 +++ /dev/null @@ -1,180 +0,0 @@ -module rrtmgp_lw_gas_optics_pre - use machine, only: kind_phys - use ccpp_gas_concentrations, only: ty_gas_concs_ccpp - - implicit none - - public :: rrtmgp_lw_gas_optics_pre_run -contains - -!> \section arg_table_rrtmgp_lw_gas_optics_pre_run Argument Table -!! \htmlinclude rrtmgp_lw_gas_optics_pre_run.html -!! - subroutine rrtmgp_lw_gas_optics_pre_run(icall, rad_const_array, pmid, pint, nlay, ncol, gaslist, idxday, & - pverp, ktoprad, ktopcam, dolw, nradgas, gas_concs, errmsg, errflg) - - ! Set gas vmr for the gases in the radconstants module's gaslist. - - integer, intent(in) :: icall ! Subcycle index of climate/diagnostic radiation call - character(len=*), intent(in) :: gaslist(:) ! Radiatively active gases - integer, intent(in) :: nlay ! Number of layers in radiation calculation - integer, intent(in) :: ncol ! Total number of columns - integer, intent(in) :: pverp ! Total number of layer interfaces - integer, intent(in) :: idxday(:) ! Indices of daylight columns - integer, intent(in) :: ktoprad ! Index in RRTMGP array corresponding to top layer or interface of CAM arrays - integer, intent(in) :: ktopcam ! Index in CAM arrays of top level (layer or interface) at which RRTMGP is active - integer, intent(in) :: nradgas ! Number of radiatively active gases - logical, intent(in) :: dolw ! Flag for whether to perform longwave calculaion - real(kind_phys), intent(in) :: pmid(:,:) ! Air pressure at midpoints [Pa] - real(kind_phys), intent(in) :: pint(:,:) ! Air pressure at interfaces [Pa] - real(kind_phys), intent(in) :: rad_const_array(:,:,:) ! array of radiatively-active constituent vmrs - ! last index corresponds to index in gaslist - - type(ty_gas_concs_ccpp), intent(inout) :: gas_concs ! the result is VMR inside gas_concs - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i, gas_idx, idx(ncol) - integer :: istat - real(kind_phys) :: gas_mmr(ncol, nlay) - real(kind_phys) :: gas_vmr(ncol, nlay) - real(kind_phys) :: mmr(ncol, nlay) - real(kind_phys) :: massratio - character(len=256) :: alloc_errmsg - - ! For ozone profile above model - real(kind_phys) :: P_top, P_int, P_mid, alpha, beta, a, b, chi_mid, chi_0, chi_eff - - character(len=*), parameter :: sub = 'rrtmgp_lw_gas_optics_pre_run' - !---------------------------------------------------------------------------- - - ! Set error variables - errmsg = '' - errflg = 0 - - if (.not. dolw) then - return - end if - - ! set the column indices; just count for longwave - do i = 1, ncol - idx(i) = i - end do - - do gas_idx = 1, nradgas - - ! grab mass mixing ratio of gas - gas_mmr = rad_const_array(:,:,gas_idx) - - do i = 1, ncol - 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 - - ! special case: H2O is specific humidity, not mixing ratio. Use r = q/(1-q): - if (gaslist(gas_idx) == 'H2O') then - mmr = mmr / (1._kind_phys - mmr) - end if - - ! convert MMR to VMR, multipy by ratio of dry air molar mas to gas molar mass. - call get_molar_mass_ratio(gaslist(gas_idx), massratio, errmsg, errflg) - if (errflg /= 0) then - return - end if - gas_vmr = mmr * massratio - - ! 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 ((gaslist(gas_idx) == 'O3') .and. (nlay == pverp)) then - P_top = 50.0_kind_phys - do i = 1, ncol - P_int = pint(idx(i),1) ! pressure (Pa) at upper interface of CAM - P_mid = pmid(idx(i),1) ! pressure (Pa) at midpoint of top layer of CAM - alpha = log(P_int/P_top) - beta = log(P_mid/P_int)/log(P_mid/P_top) - - a = ( (1._kind_phys + alpha) * exp(-alpha) - 1._kind_phys ) / alpha - b = 1._kind_phys - exp(-alpha) - - 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._kind_phys + beta) - chi_eff = chi_0 * (a + b) - gas_vmr(i,1) = chi_eff - end if - end do - end if - - errmsg = gas_concs%gas_concs%set_vmr(gaslist(gas_idx), gas_vmr) - if (len_trim(errmsg) > 0) then - errflg = 1 - return - end if - - end do - - end subroutine rrtmgp_lw_gas_optics_pre_run - -!========================================================================================= - - subroutine get_molar_mass_ratio(gas_name, massratio, errmsg, errflg) - - ! return the molar mass ratio of dry air to gas based on gas_name - - character(len=*), intent(in) :: gas_name - real(kind_phys), intent(out) :: massratio - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - real(kind_phys), parameter :: amdw = 1.607793_kind_phys ! Molecular weight of dry air / water vapor - real(kind_phys), parameter :: amdc = 0.658114_kind_phys ! Molecular weight of dry air / carbon dioxide - real(kind_phys), parameter :: amdo = 0.603428_kind_phys ! Molecular weight of dry air / ozone - real(kind_phys), parameter :: amdm = 1.805423_kind_phys ! Molecular weight of dry air / methane - real(kind_phys), parameter :: amdn = 0.658090_kind_phys ! Molecular weight of dry air / nitrous oxide - real(kind_phys), parameter :: amdo2 = 0.905140_kind_phys ! Molecular weight of dry air / oxygen - real(kind_phys), parameter :: amdc1 = 0.210852_kind_phys ! Molecular weight of dry air / CFC11 - real(kind_phys), parameter :: amdc2 = 0.239546_kind_phys ! Molecular weight of dry air / CFC12 - - character(len=*), parameter :: sub='get_molar_mass_ratio' - !---------------------------------------------------------------------------- - ! Set error variables - errmsg = '' - errflg = 0 - - select case (trim(gas_name)) - case ('H2O') - massratio = amdw - case ('CO2') - massratio = amdc - case ('O3') - massratio = amdo - case ('CH4') - massratio = amdm - case ('N2O') - massratio = amdn - case ('O2') - massratio = amdo2 - case ('CFC11') - massratio = amdc1 - case ('CFC12') - massratio = amdc2 - case default - write(errmsg, '(a,a,a)') sub, ': Invalid gas: ', trim(gas_name) - errflg = 1 - end select - -end subroutine get_molar_mass_ratio - - -end module rrtmgp_lw_gas_optics_pre diff --git a/src/physics/rrtmgp/rrtmgp_lw_main.F90 b/src/physics/rrtmgp/rrtmgp_lw_main.F90 deleted file mode 100644 index 88b14c6f61..0000000000 --- a/src/physics/rrtmgp/rrtmgp_lw_main.F90 +++ /dev/null @@ -1,287 +0,0 @@ -!> \file rrtmgp_lw_main.F90 -!! This file contains the core longwave RRTMGP radiation calcuation - -!> This module contains the call to the RRTMGP-LW radiation routine -module rrtmgp_lw_main - use machine, only: kind_phys - use mo_rte_lw, only: rte_lw - use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp - use ccpp_optical_props, only: ty_optical_props_1scl_ccpp - use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp - use ccpp_fluxes, only: ty_fluxes_broadband_ccpp - use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp - use ccpp_source_functions, only: ty_source_func_lw_ccpp - use radiation_tools, only: check_error_msg - implicit none - - public rrtmgp_lw_main_run -contains - -!> \section arg_table_rrtmgp_lw_main_run Argument Table -!! \htmlinclude rrtmgp_lw_main_run.html -!! - subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, doGP_lwscat, use_LW_jacobian, use_LW_optimal_angles, & - nGauss_angles, nCol, iter_num, rrtmgp_phys_blksz, lw_optical_props_clrsky, & - lw_optical_props_clouds, top_at_1, sources, sfc_emiss_byband, lw_gas_props, & - aerlw, fluxlwUP_jac, lw_Ds, flux_clrsky, flux_allsky, errmsg, errflg) - - ! Inputs - logical, intent(in) :: doLWrad !< Flag to perform longwave calculation - logical, intent(in) :: doLWclrsky !< Flag to compute clear-sky fluxes - logical, intent(in) :: doGP_lwscat !< Flag to include scattering in clouds - logical, intent(in) :: use_LW_jacobian !< Flag to compute Jacobian - logical, intent(in) :: use_LW_optimal_angles !< Flag to compute and use optimal angles - logical, intent(in) :: top_at_1 !< Flag for vertical ordering convention - - integer, intent(in) :: nGauss_angles !< Number of gaussian quadrature angles used - integer, intent(in) :: nCol !< Number of horizontal points - integer, intent(in) :: iter_num !< Radiation subcycle iteration number - integer, intent(in) :: rrtmgp_phys_blksz !< Number of horizontal points to process at once - - real(kind_phys), dimension(:,:), intent(in) :: sfc_emiss_byband !< Surface emissivity by band - class(ty_source_func_lw_ccpp), intent(in) :: sources !< Longwave sources object - - ! Outputs - real(kind_phys), dimension(:,:), intent(inout) :: fluxlwUP_jac !< Surface temperature flux Jacobian [W m-2 K-1] - class(ty_fluxes_byband_ccpp), intent(inout) :: flux_allsky !< All-sky flux [W m-2] - class(ty_fluxes_broadband_ccpp), intent(inout) :: flux_clrsky !< Clear-sky flux [W m-2] - class(ty_optical_props_1scl_ccpp), intent(inout) :: aerlw !< Aerosol optical properties object - class(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clrsky !< Clear-sky optical properties object - class(ty_optical_props_1scl_ccpp), intent(inout) :: lw_optical_props_clouds !< Cloud optical properties object - - class(ty_gas_optics_rrtmgp_ccpp), intent(inout) :: lw_gas_props !< Gas optical properties object - - real(kind_phys), dimension(:,:), intent(out) :: lw_Ds !< 1/cos of transport angle per column, g-point - character(len=*), intent(out) :: errmsg !< CCPP error message - integer, intent(out) :: errflg !< CCPP error flag - - ! Local variables - integer :: iCol, iCol2 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doLWrad) return - - iCol = ((iter_num - 1) * rrtmgp_phys_blksz) + 1 - iCol2 = min(iCol + rrtmgp_phys_blksz - 1, nCol) - - ! ################################################################################### - ! - ! Compute clear-sky fluxes (gaseous+aerosol) (optional) - ! - ! ################################################################################### - ! Increment - errmsg = aerlw%optical_props%increment(lw_optical_props_clrsky%optical_props) - call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - return - end if - - ! Call RTE solver - if (doLWclrsky) then - if (nGauss_angles .gt. 1) then - errmsg = rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky%fluxes, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles) ! IN - Number of angles in Gaussian quadrature - call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - return - end if - else - if (use_lw_optimal_angles) then - errmsg = lw_gas_props%gas_props%compute_optimal_angles(lw_optical_props_clrsky%optical_props,lw_Ds) - call check_error_msg('rrtmgp_lw_main_opt_angle', errmsg) - if (len_trim(errmsg) /= 0) then - errflg = 1 - return - end if - errmsg = rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky%fluxes, & ! OUT - Fluxes - lw_Ds = lw_Ds) - call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - return - end if - else - errmsg = rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_clrsky%fluxes) ! OUT - Fluxes - call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - return - end if - end if - endif - end if - - ! ################################################################################### - ! - ! All-sky fluxes (clear-sky + clouds + precipitation) - ! *Note* CCPP does not allow for polymorphic types, they are ambiguous to the CCPP - ! framework. rte-rrtmgp uses polymorphic types extensively, for example, querying the - ! type to determine physics configuration/pathway/etc... - ! - ! The logic in the code below is to satisfy the polymorphishm in the rte-rrtmgp code. - ! The rte-rrtmgp "increment" procedures are utilized to provide the correct type to the - ! rte solver (rte_lw). Rte_lw quieries the type determine if scattering is to be - ! included in the calculation. The increment procedures are called so that the correct - ! optical properties are inherited. - ! - ! ################################################################################### - - ! Include LW cloud-scattering? - if (doGP_lwscat) then - ! Increment - errmsg = lw_optical_props_clrsky%optical_props%increment(lw_optical_props_clouds%optical_props) - call check_error_msg('rrtmgp_lw_main_increment_clrsky_to_clouds', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - return - end if - - if (use_LW_jacobian) then - if (nGauss_angles .gt. 1) then - ! Compute LW Jacobians; use Gaussian angles - errmsg = rte_lw( & - lw_optical_props_clouds%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature - flux_up_Jac = fluxlwUP_jac) ! OUT - surface temperature flux (upward) Jacobian (W m-2 K-1) - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - end if - else - ! Compute LW Jacobians; don't use Gaussian angles - errmsg = rte_lw( & - lw_optical_props_clouds%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - flux_up_Jac = fluxlwUP_jac) ! OUT - surface temperature flux (upward) Jacobian (W m-2 K-1) - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - end if - end if - else - if (nGauss_angles .gt. 1) then - ! Compute LW Jacobians; use Gaussian angles - ! Don't compute LW Jacobians; use Gaussian angles - errmsg = rte_lw( & - lw_optical_props_clouds%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles) ! IN - Number of angles in Gaussian quadrature - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - end if - else - ! Don't compute LW Jacobians; don't use Gaussian angles - errmsg = rte_lw( & - lw_optical_props_clouds%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes) ! OUT - Fluxes - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - end if - end if - end if - ! No scattering in LW clouds. - else - ! Increment - errmsg = lw_optical_props_clouds%optical_props%increment(lw_optical_props_clrsky%optical_props) - call check_error_msg('rrtmgp_lw_main_increment_clouds_to_clrsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - return - end if - - if (use_LW_jacobian) then - if (nGauss_angles .gt. 1) then - ! Compute LW Jacobians; use Gaussian angles - errmsg = rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles, & ! IN - Number of angles in Gaussian quadrature - flux_up_Jac = fluxlwUP_jac) ! OUT - surface temperature flux (upward) Jacobian (W m-2 K-1) - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - end if - else - ! Compute LW Jacobians; don't use Gaussian angles - errmsg = rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - flux_up_Jac = fluxlwUP_jac) ! OUT - surface temperature flux (upward) Jacobian (W m-2 K-1) - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - end if - end if - else - if (nGauss_angles .gt. 1) then - ! Don't compute LW Jacobians; use Gaussian angles - errmsg = rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes, & ! OUT - Fluxes - n_gauss_angles = nGauss_angles) ! IN - Number of angles in Gaussian quadrature - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) - if (len_trim(errmsg) =/ 0) then - errflg = 1 - end if - else - ! Don't compute LW Jacobians; don't use Gaussian angles - errmsg = rte_lw( & - lw_optical_props_clrsky%optical_props, & ! IN - optical-properties - top_at_1, & ! IN - vertical ordering flag - sources%sources, & ! IN - source function - sfc_emiss_byband, & ! IN - surface emissivity in each LW band - flux_allsky%fluxes) ! OUT - Fluxes - call check_error_msg('rrtmgp_lw_main_lw_rte_allsky', errmsg) - if (len_trim(errmsg) /= 0) then - errflg = 1 - end if - end if - end if - end if - - end subroutine rrtmgp_lw_main_run -end module rrtmgp_lw_main diff --git a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 b/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 deleted file mode 100644 index 8c2169404a..0000000000 --- a/src/physics/rrtmgp/rrtmgp_lw_mcica_subcol_gen.F90 +++ /dev/null @@ -1,195 +0,0 @@ -module rrtmgp_lw_mcica_subcol_gen -! PEVERWHEE - dependencies = shr_RandNum_mod - -!---------------------------------------------------------------------------------------- -! -! Purpose: Create McICA stochastic arrays for lw 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). | -! | 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/) | -! | | -! -------------------------------------------------------------------------- -! This code is a refactored version of code originally in the files -! rrtmgp_lw_mcica_subcol_gen.F90 and mcica_subcol_gen_sw.F90 -! -! Uses the KISS random number generator. -! -! Overlap assumption: maximum-random. -! -!---------------------------------------------------------------------------------------- - -use machine, only: kind_phys -use shr_RandNum_mod, only: ShrKissRandGen -use ccpp_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp_ccpp -use ccpp_optical_props, only: ty_optical_props_1scl_ccpp - -implicit none -private -save - -public :: rrtmgp_lw_mcica_subcol_gen_run - -!======================================================================================== -contains -!======================================================================================== - -!> -!> \section arg_table_rrtmgp_lw_mcica_subcol_gen_run Argument Table -!! \htmlinclude rrtmgp_lw_mcica_subcol_gen_run.html -subroutine rrtmgp_lw_mcica_subcol_gen_run( & - dolw, ktoprad, kdist, nbnd, ngpt, ncol, pver, nver, & - changeseed, pmid, cldfrac, tauc, cloud_lw, & - errmsg, errflg ) - - ! 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_rrtmgp_ccpp), intent(in) :: kdist ! Gas optics object - logical, intent(in) :: dolw ! Flag for whether to perform longwave calculation - integer, intent(in) :: ktoprad ! Index in RRTMGP array corresponding to top layer or interface of CAM arrays - 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) :: pver ! Number of model layers - integer, intent(in) :: nver ! Number of layers in radiation calculation - integer, intent(in) :: changeseed ! If the subcolumn generator is called multiple times, - ! permute the seed between each call. - real(kind_phys), dimension(:,:), intent(in) :: pmid ! Layer pressures at midpoints (Pa) - real(kind_phys), dimension(:,:), intent(in) :: cldfrac ! Layer cloud fraction - real(kind_phys), dimension(:,:,:), intent(in) :: tauc ! Cloud optical depth - type(ty_optical_props_1scl_ccpp), intent(inout) :: cloud_lw ! Cloud optics object - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - - integer :: idx, isubcol, kdx, ndx - - real(kind_phys), parameter :: cldmin = 1.0e-80_kind_phys ! min cloud fraction - real(kind_phys) :: cldf(ncol,nver) ! cloud fraction clipped to cldmin - - type(ShrKissRandGen) :: kiss_gen ! KISS RNG object - integer :: kiss_seed(ncol,4) - real(kind_phys) :: rand_num_1d(ncol,1) ! random number (kissvec) - real(kind_phys) :: rand_num(ncol,nver) ! random number (kissvec) - - real(kind_phys) :: cdf(ngpt,ncol,nver) ! random numbers - logical :: iscloudy(ngpt,ncol,nver) ! flag that says whether a gridbox is cloudy - real(kind_phys) :: taucmcl(ngpt,ncol,nver) - !------------------------------------------------------------------------------------------ - - ! Set error variables - errflg = 0 - errmsg = '' - - ! If we're not doing longwave this timestep, no need to proceed - if (.not. dolw) then - return - end if - - ! clip cloud fraction - cldf(:,:) = cldfrac(:ncol,:) - where (cldf(:,:) < cldmin) - cldf(:,:) = 0._kind_phys - end where - - ! Create a seed that depends on the state of the columns. - ! Use pmid from bottom four layers. - do idx = 1, ncol - kiss_seed(idx,1) = (pmid(idx,pver) - int(pmid(idx,pver))) * 1000000000 - kiss_seed(idx,2) = (pmid(idx,pver-1) - int(pmid(idx,pver-1))) * 1000000000 - kiss_seed(idx,3) = (pmid(idx,pver-2) - int(pmid(idx,pver-2))) * 1000000000 - kiss_seed(idx,4) = (pmid(idx,pver-3) - int(pmid(idx,pver-3))) * 1000000000 - end do - - ! create the RNG object - kiss_gen = ShrKissRandGen(kiss_seed) - - ! Advance randum number generator by changeseed values - do idx = 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 kdx = 2, nver - do idx = 1, ncol - do isubcol = 1, ngpt - if (cdf(isubcol,idx,kdx-1) > 1._kind_phys - cldf(idx,kdx-1) ) then - cdf(isubcol,idx,kdx) = cdf(isubcol,idx,kdx-1) - else - cdf(isubcol,idx,kdx) = cdf(isubcol,idx,kdx) * (1._kind_phys - cldf(idx,kdx-1)) - end if - end do - end do - end do - - do kdx = 1, nver - iscloudy(:,:,kdx) = (cdf(:,:,kdx) >= 1._kind_phys - spread(cldf(:,kdx), 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 kdx = 1,nver - do idx = 1,ncol - do isubcol = 1,ngpt - if (iscloudy(isubcol,idx,kdx) .and. (cldf(idx,kdx) > 0._kind_phys) ) then - ndx = kdist%gas_props%convert_gpt2band(isubcol) - taucmcl(isubcol,idx,kdx) = tauc(ndx,idx,kdx) - else - taucmcl(isubcol,idx,kdx) = 0._kind_phys - end if - end do - end do - end do - - call kiss_gen%finalize() - - ! If there is an extra layer in the radiation then this initialization - ! will provide zero optical depths there - cloud_lw%optical_props%tau = 0.0_kind_phys - - ! Set the properties on g-points - do idx = 1, ngpt - cloud_lw%optical_props%tau(:,ktoprad:,idx) = taucmcl(idx,:,:) - end do - - ! validate checks that: tau > 0 - errmsg = cloud_lw%optical_props%validate() - if (len_trim(errmsg) > 0) then - errflg = 1 - return - end if - -end subroutine rrtmgp_lw_mcica_subcol_gen_run - - -end module rrtmgp_lw_mcica_subcol_gen - diff --git a/src/physics/rrtmgp/rrtmgp_post.F90 b/src/physics/rrtmgp/rrtmgp_post.F90 deleted file mode 100644 index cb416be841..0000000000 --- a/src/physics/rrtmgp/rrtmgp_post.F90 +++ /dev/null @@ -1,116 +0,0 @@ -module rrtmgp_post - - use ccpp_kinds, only: kind_phys - use ccpp_optical_props, only: ty_optical_props_1scl_ccpp, ty_optical_props_2str_ccpp - use ccpp_source_functions, only: ty_source_func_lw_ccpp - use ccpp_fluxes, only: ty_fluxes_broadband_ccpp - use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp - - public :: rrtmgp_post_run - -contains -!> \section arg_table_rrtmgp_post_run Argument Table -!! \htmlinclude rrtmgp_post_run.html -!! -subroutine rrtmgp_post_run(ncol, qrs, qrl, fsns, pdel, atm_optics_sw, cloud_sw, aer_sw, & - fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, netsw, errmsg, errflg) - integer, intent(in) :: ncol ! Number of columns - real(kind_phys), dimension(:,:), intent(in) :: pdel ! Layer thickness [Pa] - real(kind_phys), dimension(:), intent(in) :: fsns ! Surface net shortwave flux [W m-2] - real(kind_phys), dimension(:,:), intent(inout) :: qrs ! Shortwave heating rate [J kg-1 s-1] - real(kind_phys), dimension(:,:), intent(inout) :: qrl ! Longwave heating rate [J kg-1 s-1] - type(ty_optical_props_2str_ccpp), intent(inout) :: atm_optics_sw ! Atmosphere optical properties object (shortwave) - type(ty_optical_props_1scl_ccpp), intent(inout) :: aer_lw ! Aerosol optical properties object (longwave) - type(ty_optical_props_2str_ccpp), intent(inout) :: aer_sw ! Aerosol optical properties object (shortwave) - type(ty_optical_props_1scl_ccpp), intent(inout) :: cloud_lw ! Cloud optical properties object (longwave) - type(ty_optical_props_2str_ccpp), intent(inout) :: cloud_sw ! Cloud optical properties object (shortwave) - type(ty_fluxes_broadband_ccpp), intent(inout) :: fswc ! Shortwave clear-sky flux object - type(ty_fluxes_broadband_ccpp), intent(inout) :: flwc ! Longwave clear-sky flux object - type(ty_fluxes_byband_ccpp), intent(inout) :: fsw ! Shortwave all-sky flux object - type(ty_fluxes_byband_ccpp), intent(inout) :: flw ! Longwave all-sky flux object - type(ty_source_func_lw_ccpp), intent(inout) :: sources_lw ! Longwave sources object - real(kind_phys), dimension(:), intent(out) :: netsw ! Net shortwave flux to be sent to coupler [W m-2] - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Set error varaibles - errflg = 0 - errmsg = '' - ! The radiative heating rates are carried in the physics buffer across timesteps - ! as Q*dp (for energy conservation). - qrs(:ncol,:) = qrs(:ncol,:) * pdel(:ncol,:) - qrl(:ncol,:) = qrl(:ncol,:) * pdel(:ncol,:) - - ! Set the netsw to be sent to the coupler - netsw(:ncol) = fsns(:ncol) - - call free_optics_sw(atm_optics_sw) - call free_optics_sw(cloud_sw) - call free_optics_sw(aer_sw) - call free_fluxes_byband(fsw) - call free_fluxes_broadband(fswc) - - call sources_lw%sources%finalize() - call free_optics_lw(cloud_lw) - call free_optics_lw(aer_lw) - call free_fluxes_byband(flw) - call free_fluxes_broadband(flwc) - -end subroutine rrtmgp_post_run - - !========================================================================================= - -subroutine free_optics_sw(optics) - - type(ty_optical_props_2str_ccpp), intent(inout) :: optics - - if (allocated(optics%optical_props%tau)) deallocate(optics%optical_props%tau) - if (allocated(optics%optical_props%ssa)) deallocate(optics%optical_props%ssa) - if (allocated(optics%optical_props%g)) deallocate(optics%optical_props%g) - call optics%optical_props%finalize() - -end subroutine free_optics_sw - -!========================================================================================= - -subroutine free_optics_lw(optics) - - type(ty_optical_props_1scl_ccpp), intent(inout) :: optics - - if (allocated(optics%optical_props%tau)) deallocate(optics%optical_props%tau) - call optics%optical_props%finalize() - -end subroutine free_optics_lw - -!========================================================================================= - -subroutine free_fluxes_broadband(fluxes) - - class(ty_fluxes_broadband_ccpp), intent(inout) :: fluxes - - if (associated(fluxes%fluxes%flux_up)) deallocate(fluxes%fluxes%flux_up) - if (associated(fluxes%fluxes%flux_dn)) deallocate(fluxes%fluxes%flux_dn) - if (associated(fluxes%fluxes%flux_net)) deallocate(fluxes%fluxes%flux_net) - if (associated(fluxes%fluxes%flux_dn_dir)) deallocate(fluxes%fluxes%flux_dn_dir) - -end subroutine free_fluxes_broadband - -!========================================================================================= - -subroutine free_fluxes_byband(fluxes) - - class(ty_fluxes_byband_ccpp), intent(inout) :: fluxes - - if (associated(fluxes%fluxes%flux_up)) deallocate(fluxes%fluxes%flux_up) - if (associated(fluxes%fluxes%flux_dn)) deallocate(fluxes%fluxes%flux_dn) - if (associated(fluxes%fluxes%flux_net)) deallocate(fluxes%fluxes%flux_net) - if (associated(fluxes%fluxes%flux_dn_dir)) deallocate(fluxes%fluxes%flux_dn_dir) - - if (associated(fluxes%fluxes%bnd_flux_up)) deallocate(fluxes%fluxes%bnd_flux_up) - if (associated(fluxes%fluxes%bnd_flux_dn)) deallocate(fluxes%fluxes%bnd_flux_dn) - if (associated(fluxes%fluxes%bnd_flux_net)) deallocate(fluxes%fluxes%bnd_flux_net) - if (associated(fluxes%fluxes%bnd_flux_dn_dir)) deallocate(fluxes%fluxes%bnd_flux_dn_dir) - -end subroutine free_fluxes_byband - -end module rrtmgp_post diff --git a/src/physics/rrtmgp/rrtmgp_pre.F90 b/src/physics/rrtmgp/rrtmgp_pre.F90 deleted file mode 100644 index 2a19da1a14..0000000000 --- a/src/physics/rrtmgp/rrtmgp_pre.F90 +++ /dev/null @@ -1,386 +0,0 @@ -module rrtmgp_pre - use ccpp_kinds, only: kind_phys - use ccpp_fluxes, only: ty_fluxes_broadband_ccpp - use ccpp_fluxes_byband, only: ty_fluxes_byband_ccpp - use atmos_phys_string_utils, only: to_lower - - public :: rrtmgp_pre_init - public :: rrtmgp_pre_run - public :: radiation_do_ccpp - -CONTAINS - -!> \section arg_table_rrtmgp_pre_init Argument Table -!! \htmlinclude rrtmgp_pre_init.html -!! - subroutine rrtmgp_pre_init(nradgas, gaslist, available_gases, gaslist_lc, errmsg, errflg) - integer, intent(in) :: nradgas ! Number of radiatively active gases - character(len=*), intent(in) :: gaslist ! List of radiatively active gases - type(ty_gas_concentrations_ccpp), intent(inout) :: available_gases ! Gas concentrations object - character(len=*), intent(out) :: gaslist_lc ! Lowercase verison of radiatively active gas list - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Set error variables - errmsg = '' - errflg = 0 - - ! Create lowercase version of the gaslist for RRTMGP. The ty_gas_concs_ccpp 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%gas_concs%init(gaslist_lc) - if (len_trim(errmsg) /= 0) then - errflg = 1 - end if - - end subroutine rrtmgp_pre_init - -!> \section arg_table_rrtmgp_pre_run Argument Table -!! \htmlinclude rrtmgp_pre_run.html -!! - subroutine rrtmgp_pre_run(coszrs, nstep, dtime, iradsw, iradlw, irad_always, ncol, & - nextsw_cday, idxday, nday, idxnite, nnite, dosw, dolw, nlay, nlwbands, & - nswbands, spectralflux, fsw, fswc, flw, flwc, errmsg, errflg) - use time_manager, only: get_curr_calday - ! Inputs - real(kind_phys), dimension(:), intent(in) :: coszrs ! Cosine solar zenith angle - integer, intent(in) :: dtime ! Timestep size [s] - integer, intent(in) :: nstep ! Timestep number - integer, intent(in) :: iradsw ! Freq. of shortwave radiation calc in time steps (positive) or hours (negative) - integer, intent(in) :: iradlw ! Freq. of longwave radiation calc in time steps (positive) or hours (negative) - integer, intent(in) :: irad_always ! Number of time steps to execute radiation continuously - integer, intent(in) :: ncol ! Number of columns - integer, intent(in) :: nlay ! Number of vertical layers - integer, intent(in) :: nlwbands ! Number of longwave bands - integer, intent(in) :: nswbands ! Number of shortwave bands - logical, intent(in) :: spectralflux ! Flag to calculate fluxes (up and down) per band - ! Outputs - class(ty_fluxes_broadband_ccpp), intent(out) :: fswc ! Clear-sky shortwave flux object - class(ty_fluxes_byband_ccpp), intent(out) :: fsw ! All-sky shortwave flux object - class(ty_fluxes_broadband_ccpp), intent(out) :: flwc ! Clear-sky longwave flux object - class(ty_fluxes_byband_ccpp), intent(out) :: flw ! All-sky longwave flux object - integer, intent(out) :: nday ! Number of daylight columns - integer, intent(out) :: nnite ! Number of nighttime columns - real(kind_phys), intent(out) :: nextsw_cday ! The next calendar day during which radiation calculation will be performed - integer, dimension(:), intent(out) :: idxday ! Indices of daylight columns - integer, dimension(:), intent(out) :: idxnite ! Indices of nighttime columns - logical, intent(out) :: dosw ! Flag to do shortwave calculation - logical, intent(out) :: dolw ! Flag to do longwave calculation - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: idx - integer :: offset - integer :: nstep_next - logical :: dosw_next - real(kind_phys) :: caldayp1 - - ! Set error variables - errflg = 0 - errmsg = '' - - ! Gather night/day column indices. - nday = 0 - nnite = 0 - do idx = 1, ncol - if ( coszrs(idx) > 0.0_kind_phys ) then - nday = nday + 1 - idxday(nday) = idx - else - nnite = nnite + 1 - idxnite(nnite) = idx - end if - end do - - ! Determine if we're going to do longwave and/or shortwave this timestep - call radiation_do_ccpp('sw', nstep, iradsw, irad_always, dosw, errmsg, errflg) - if (errflg /= 0) then - return - end if - call radiation_do_ccpp('lw', nstep, iradlw, irad_always, dolw, errmsg, errflg) - if (errflg /= 0) then - return - end if - - ! Get time of next radiation calculation - albedos will need to be - ! calculated by each surface model at this time - nextsw_cday = -1._kind_phys - dosw_next = .false. - offset = 0 - nstep_next = nstep - do while (.not. dosw_next) - nstep_next = nstep_next + 1 - offset = offset + dtime - call radiation_do_ccpp('sw', nstep_next, iradsw, irad_always, dosw_next, errmsg, errflg) - if (errflg /= 0) then - return - end if - if (dosw_next) then - nextsw_cday = get_curr_calday(offset=offset) - end if - end do - if(nextsw_cday == -1._kind_phys) then - errflg = 1 - errmsg = 'next calendar day with shortwave calculation not found' - return - end if - - ! determine if next radiation time-step not equal to next time-step - if (nstep >= 1) then - caldayp1 = get_curr_calday(offset=int(dtime)) - if (caldayp1 /= nextsw_cday) nextsw_cday = -1._kind_phys - end if - - ! Allocate the flux arrays and init to zero. - call initialize_rrtmgp_fluxes_byband(nday, nlay+1, nswbands, nswbands, spectralflux, fsw, errmsg, errflg, do_direct=.true.) - if (errflg /= 0) then - return - end if - call initialize_rrtmgp_fluxes_broadband(nday, nlay+1, nswbands, nswbands, spectralflux, fswc, errmsg, errflg, do_direct=.true.) - if (errflg /= 0) then - return - end if - call initialize_rrtmgp_fluxes_byband(ncol, nlay+1, nlwbands, nswbands, spectralflux, flw, errmsg, errflg) - if (errflg /= 0) then - return - end if - call initialize_rrtmgp_fluxes_broadband(ncol, nlay+1, nlwbands, nswbands, spectralflux, flwc, errmsg, errflg) - if (errflg /= 0) then - return - end if - - end subroutine rrtmgp_pre_run - -!================================================================================================ - -subroutine radiation_do_ccpp(op, nstep, irad, irad_always, radiation_do, errmsg, errflg) - - ! Return true if the specified operation is done this timestep. - - character(len=*), intent(in) :: op ! name of operation - integer, intent(in) :: nstep - integer, intent(in) :: irad - integer, intent(in) :: irad_always - integer, intent(out) :: errflg - character(len=*), intent(out) :: errmsg - logical, intent(out) :: radiation_do ! return value - - !----------------------------------------------------------------------- - - ! Set error variables - errflg = 0 - errmsg = '' - - select case (op) - case ('sw') ! do a shortwave heating calc this timestep? - radiation_do = nstep == 0 .or. irad == 1 & - .or. (mod(nstep-1,irad) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - case ('lw') ! do a longwave heating calc this timestep? - radiation_do = nstep == 0 .or. irad == 1 & - .or. (mod(nstep-1,irad) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - case default - errflg = 1 - errmsg = 'radiation_do_ccpp: unknown operation:'//op - end select - -end subroutine radiation_do_ccpp - -!========================================================================================= - -subroutine initialize_rrtmgp_fluxes_broadband(ncol, nlevels, nbands, nswbands, spectralflux, fluxes, errmsg, errflg, do_direct) - - ! Allocate flux arrays and set values to zero. - - ! Arguments - integer, intent(in) :: ncol, nlevels, nbands, nswbands - logical, intent(in) :: spectralflux - class(ty_fluxes_broadband_ccpp), intent(inout) :: fluxes - logical, optional, intent(in) :: do_direct - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - logical :: do_direct_local - character(len=256) :: alloc_errmsg - character(len=*), parameter :: sub = 'initialize_rrtmgp_fluxes' - !---------------------------------------------------------------------------- - - if (present(do_direct)) then - do_direct_local = .true. - else - do_direct_local = .false. - end if - - ! Broadband fluxes - allocate(fluxes%fluxes%flux_up(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_up". Message: ', & - alloc_errmsg - return - end if - allocate(fluxes%fluxes%flux_dn(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_dn". Message: ', & - alloc_errmsg - return - end if - allocate(fluxes%fluxes%flux_net(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_net". Message: ', & - alloc_errmsg - return - end if - if (do_direct_local) then - allocate(fluxes%fluxes%flux_dn_dir(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_dn_dir". Message: ', & - alloc_errmsg - return - end if - end if - - ! Initialize - call reset_fluxes_broadband(fluxes) - -end subroutine initialize_rrtmgp_fluxes_broadband - -!========================================================================================= - -subroutine initialize_rrtmgp_fluxes_byband(ncol, nlevels, nbands, nswbands, spectralflux, fluxes, errmsg, errflg, do_direct) - - ! Allocate flux arrays and set values to zero. - - ! Arguments - integer, intent(in) :: ncol, nlevels, nbands, nswbands - logical, intent(in) :: spectralflux - class(ty_fluxes_byband_ccpp), intent(inout) :: fluxes - logical, optional, intent(in) :: do_direct - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - logical :: do_direct_local - character(len=256) :: alloc_errmsg - character(len=*), parameter :: sub = 'initialize_rrtmgp_fluxes_byband' - !---------------------------------------------------------------------------- - - if (present(do_direct)) then - do_direct_local = .true. - else - do_direct_local = .false. - end if - - ! Broadband fluxes - allocate(fluxes%fluxes%flux_up(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_up". Message: ', & - alloc_errmsg - return - end if - allocate(fluxes%fluxes%flux_dn(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_dn". Message: ', & - alloc_errmsg - return - end if - allocate(fluxes%fluxes%flux_net(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_net". Message: ', & - alloc_errmsg - return - end if - if (do_direct_local) then - allocate(fluxes%fluxes%flux_dn_dir(ncol, nlevels), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%flux_dn_dir". Message: ', & - alloc_errmsg - return - end if - end if - - ! Fluxes by band always needed for SW. Only allocate for LW - ! when spectralflux is true. - if (nbands == nswbands .or. spectralflux) then - allocate(fluxes%fluxes%bnd_flux_up(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%bnd_flux_up". Message: ', & - alloc_errmsg - return - end if - allocate(fluxes%fluxes%bnd_flux_dn(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%bnd_flux_dn". Message: ', & - alloc_errmsg - return - end if - allocate(fluxes%fluxes%bnd_flux_net(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%bnd_flux_net". Message: ', & - alloc_errmsg - return - end if - if (do_direct_local) then - allocate(fluxes%fluxes%bnd_flux_dn_dir(ncol, nlevels, nbands), stat=errflg, errmsg=alloc_errmsg) - if (errflg /= 0) then - write(errmsg, '(a,a,a)') sub, ': ERROR: failed to allocate "fluxes%fluxes%bnd_flux_dn_dir". Message: ', & - alloc_errmsg - return - end if - end if - end if - - ! Initialize - call reset_fluxes_byband(fluxes) - -end subroutine initialize_rrtmgp_fluxes_byband - -!========================================================================================= - -subroutine reset_fluxes_broadband(fluxes) - - ! Reset flux arrays to zero. - - class(ty_fluxes_broadband_ccpp), intent(inout) :: fluxes - !---------------------------------------------------------------------------- - - ! Reset broadband fluxes - fluxes%fluxes%flux_up(:,:) = 0._kind_phys - fluxes%fluxes%flux_dn(:,:) = 0._kind_phys - fluxes%fluxes%flux_net(:,:) = 0._kind_phys - if (associated(fluxes%fluxes%flux_dn_dir)) fluxes%fluxes%flux_dn_dir(:,:) = 0._kind_phys - -end subroutine reset_fluxes_broadband - -!========================================================================================= - -subroutine reset_fluxes_byband(fluxes) - - ! Reset flux arrays to zero. - - class(ty_fluxes_byband_ccpp), intent(inout) :: fluxes - !---------------------------------------------------------------------------- - - ! Reset broadband fluxes - fluxes%fluxes%flux_up(:,:) = 0._kind_phys - fluxes%fluxes%flux_dn(:,:) = 0._kind_phys - fluxes%fluxes%flux_net(:,:) = 0._kind_phys - if (associated(fluxes%fluxes%flux_dn_dir)) fluxes%fluxes%flux_dn_dir(:,:) = 0._kind_phys - - ! Reset band-by-band fluxes - if (associated(fluxes%fluxes%bnd_flux_up)) fluxes%fluxes%bnd_flux_up(:,:,:) = 0._kind_phys - if (associated(fluxes%fluxes%bnd_flux_dn)) fluxes%fluxes%bnd_flux_dn(:,:,:) = 0._kind_phys - if (associated(fluxes%fluxes%bnd_flux_net)) fluxes%fluxes%bnd_flux_net(:,:,:) = 0._kind_phys - if (associated(fluxes%fluxes%bnd_flux_dn_dir)) fluxes%fluxes%bnd_flux_dn_dir(:,:,:) = 0._kind_phys - -end subroutine reset_fluxes_byband - -!========================================================================================= - -end module rrtmgp_pre From 75e783831d320e79182a337449c6ea574efaf7e7 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Fri, 4 Apr 2025 10:11:05 -0600 Subject: [PATCH 11/17] update atmos_phys hash --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 79a74c41a2..9081a337e1 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,7 +36,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/peverwhee/atmospheric_physics - fxtag = 12c79730f280e7c5427743c706255ff2820df64e + fxtag = 4144fc19c9f619028e559a2778d956ea61106cbe fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics From 217b141c6c824d903cad87a0a0ea4d45d44e8cf8 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Sat, 5 Apr 2025 23:30:18 -0600 Subject: [PATCH 12/17] update interface to calculate current calendar day on "host" side --- .gitmodules | 2 +- src/physics/rrtmgp/radiation.F90 | 19 ++++++++++++++++--- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/.gitmodules b/.gitmodules index 9081a337e1..e290e0f17c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,7 +36,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/peverwhee/atmospheric_physics - fxtag = 4144fc19c9f619028e559a2778d956ea61106cbe + fxtag = ea93c7474053cc6d2200c2ae059b7d5c5387cf45 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 776223083b..2388c247d9 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -813,7 +813,7 @@ subroutine radiation_tend( & ! CCPPized schemes use rrtmgp_inputs, only: rrtmgp_inputs_run - use rrtmgp_pre, only: rrtmgp_pre_run + use rrtmgp_pre, only: rrtmgp_pre_run, rrtmgp_pre_timestep_init use rrtmgp_lw_cloud_optics, only: rrtmgp_lw_cloud_optics_run use rrtmgp_lw_mcica_subcol_gen, only: rrtmgp_lw_mcica_subcol_gen_run use rrtmgp_lw_gas_optics_pre, only: rrtmgp_lw_gas_optics_pre_run @@ -868,6 +868,9 @@ subroutine radiation_tend( & real(r8) :: coszrs(pcols) ! Cosine solar zenith angle integer :: itim_old + integer :: nextsw_nstep + integer :: offset + real(r8) :: next_cday real(r8), pointer :: cld(:,:) ! cloud fraction real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds" @@ -1024,11 +1027,21 @@ subroutine radiation_tend( & end do end if + ! Get next SW radiation timestep + call rrtmgp_pre_timestep_init(get_nstep(), get_step_size(), iradsw, irad_always, offset, errmsg, errflg) + if (errflg /= 0) then + call endrun(sub//': '//errmsg) + end if + + ! Calculate next calendar day and next radiation calendar day + nextsw_cday = get_curr_calday(offset=offset) + next_cday = get_curr_calday(offset=int(get_step_size())) + ! Determine if we're running radiation (sw and/or lw) this timestep, ! find daylight and nighttime indices, and initialize fluxes call rrtmgp_pre_run(coszrs, get_nstep(), get_step_size(), iradsw, iradlw, irad_always, & - ncol, nextsw_cday, idxday, nday, idxnite, nnite, dosw, dolw, nlay, nlwbands, & - nswbands, spectralflux, fsw, fswc, flw, flwc, errmsg, errflg) + ncol, next_cday, idxday, nday, idxnite, nnite, dosw, dolw, nlay, nlwbands, & + nswbands, spectralflux, nextsw_cday, fsw, fswc, flw, flwc, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if From 6deb499b8dfa076ad9fe9091f5419e5bb6c9b718 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Mon, 7 Apr 2025 13:38:24 -0600 Subject: [PATCH 13/17] remove unused variable --- .gitmodules | 2 +- src/physics/rrtmgp/radiation.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index e290e0f17c..1cae16ea4d 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,7 +36,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/peverwhee/atmospheric_physics - fxtag = ea93c7474053cc6d2200c2ae059b7d5c5387cf45 + fxtag = 032a2520b657774b93dc661ccab24aa677bcf16c fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 2388c247d9..97ac3d95a8 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1289,7 +1289,7 @@ subroutine radiation_tend( & call rrtmgp_get_gas_mmrs(icall, state, pbuf, nlay, gas_mmrs) ! Set gas volume mixing ratios for this call in gas_concs_lw - call rrtmgp_lw_gas_optics_pre_run(icall, gas_mmrs, state%pmid, state%pint, nlay, ncol, gaslist, & + call rrtmgp_lw_gas_optics_pre_run(gas_mmrs, state%pmid, state%pint, nlay, ncol, gaslist, & idxday, pverp, ktoprad, ktopcam, dolw, nradgas, gas_concs_lw, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) From 49611674dec6aabe87522a119fde7d42a2a785a3 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Thu, 10 Apr 2025 15:07:41 -0600 Subject: [PATCH 14/17] subset arrays in call to ccpp layers --- src/physics/cam/radheat.F90 | 13 +++++++--- src/physics/rrtmgp/radiation.F90 | 42 +++++++++++++++++++------------- 2 files changed, 34 insertions(+), 21 deletions(-) diff --git a/src/physics/cam/radheat.F90 b/src/physics/cam/radheat.F90 index 5fe856966c..15ab38a843 100644 --- a/src/physics/cam/radheat.F90 +++ b/src/physics/cam/radheat.F90 @@ -118,6 +118,11 @@ subroutine radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & call physics_ptend_init(ptend,state%psetcols, 'radheat', ls=.true.) + ! REMOVECAM no longer need once CAM is retired and pcols doesn't exist + ptend%s(:,:) = 0._r8 + net_flx(:) = 0._r8 + ! END_REMOVECAM + #if ( defined OFFLINE_DYN ) ptend%s(:ncol,:) = 0._r8 do k = 1,pver @@ -125,11 +130,11 @@ subroutine radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & ptend%s(:ncol,k) = (qrs(:ncol,k) + qrl(:ncol,k)) endif enddo - call calculate_net_heating_run(ncol, ptend%s, qrl, qrs, fsns, fsnt, flns, flnt, & - .true., net_flx, errmsg, errflg) + call calculate_net_heating_run(ncol, ptend%s(:ncol,:), qrl(:ncol,:), qrs(:ncol,:), fsns, fsnt, flns, & + flnt, .true., net_flx(:ncol), errmsg, errflg) #else - call calculate_net_heating_run(ncol, ptend%s, qrl, qrs, fsns, fsnt, flns, flnt, & - .false., net_flx, errmsg, errflg) + call calculate_net_heating_run(ncol, ptend%s(:ncol,:), qrl(:ncol,:), qrs(:ncol,:), fsns, fsnt, flns, & + flnt, .false., net_flx(:ncol), errmsg, errflg) #endif end subroutine radheat_tend diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 97ac3d95a8..1cad027e7c 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1039,7 +1039,7 @@ subroutine radiation_tend( & ! Determine if we're running radiation (sw and/or lw) this timestep, ! find daylight and nighttime indices, and initialize fluxes - call rrtmgp_pre_run(coszrs, get_nstep(), get_step_size(), iradsw, iradlw, irad_always, & + call rrtmgp_pre_run(coszrs(:ncol), get_nstep(), get_step_size(), iradsw, iradlw, irad_always, & ncol, next_cday, idxday, nday, idxnite, nnite, dosw, dolw, nlay, nlwbands, & nswbands, spectralflux, nextsw_cday, fsw, fswc, flw, flwc, errmsg, errflg) if (errflg /= 0) then @@ -1082,6 +1082,11 @@ subroutine radiation_tend( & end do end if + !REMOVECAM - no longer need this when CAM is retired and pcols no longer exists + flns(:) = 0._r8 + flnt(:) = 0._r8 + !REMOVECAM_END + ! Find tropopause height if needed for diagnostic output if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then !REMOVECAM - no longer need this when CAM is retired and pcols no longer exists @@ -1110,14 +1115,14 @@ subroutine radiation_tend( & ! Prepare state variables, daylit columns, albedos for RRTMGP ! Also calculate modified cloud fraction call rrtmgp_inputs_run(dosw, dolw, associated(cldfsnow), associated(cldfgrau), & - state%pmid, state%pint, state%t, & - nday, idxday, cldfprime, coszrs, kdist_sw, t_sfc, & + state%pmid(:ncol,:), state%pint(:ncol,:), state%t(:ncol,:), & + nday, idxday, cldfprime(:ncol,:), coszrs(:ncol), kdist_sw, t_sfc, & emis_sfc, t_rad, pmid_rad, pint_rad, t_day, pmid_day, & - pint_day, coszrs_day, alb_dir, alb_dif, cam_in%lwup, stebol, & - ncol, ktopcam, ktoprad, nswbands, cam_in%asdir, cam_in%asdif, & - sw_low_bounds, sw_high_bounds, cam_in%aldir, cam_in%aldif, nlay, & - pverp, pver, cld, cldfsnow, cldfgrau, graupel_in_rad, & - gasnamelength, gaslist, gas_concs_lw, aer_lw, atm_optics_lw, & + pint_day, coszrs_day, alb_dir, alb_dif, cam_in%lwup(:ncol), stebol, & + ncol, ktopcam, ktoprad, nswbands, cam_in%asdir(:ncol), cam_in%asdif(:ncol), & + sw_low_bounds, sw_high_bounds, cam_in%aldir(:ncol), cam_in%aldif(:ncol), nlay, & + pverp, pver, cld(:ncol,:), cldfsnow(:ncol,:), cldfgrau(:ncol,:), & + graupel_in_rad, gasnamelength, gaslist, gas_concs_lw, aer_lw, atm_optics_lw, & kdist_lw, sources_lw, aer_sw, atm_optics_sw, gas_concs_sw, & errmsg, errflg) if (errflg /= 0) then @@ -1259,9 +1264,10 @@ subroutine radiation_tend( & do_snow = associated(cldfsnow) ! Set cloud optical properties in cloud_lw object. - call rrtmgp_lw_cloud_optics_run(dolw, ncol, nlay, nlaycam, cld, cldfsnow, cldfgrau, & - cldfprime, graupel_in_rad, kdist_lw, cloud_lw, lambda, mu, iclwp, iciwp, & - dei, icswp, des, icgrauwp, degrau, nlwbands, do_snow, do_graupel, pver, & + call rrtmgp_lw_cloud_optics_run(dolw, ncol, nlay, nlaycam, cld(:ncol,:), cldfsnow(:ncol,:), & + cldfgrau(:ncol,:), cldfprime(:ncol,:), graupel_in_rad, kdist_lw, cloud_lw, lambda(:ncol,:), & + mu(:ncol,:), iclwp(:ncol,:), iciwp(:ncol,:), dei(:ncol,:), icswp(:ncol,:), des(:ncol,:), & + icgrauwp(:ncol,:), degrau(:ncol,:), nlwbands, do_snow, do_graupel, pver, & ktopcam, tauc, cldf, cld_lw_abs, snow_lw_abs, grau_lw_abs, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) @@ -1275,7 +1281,7 @@ subroutine radiation_tend( & ! Create McICA stochastic arrays for lw cloud optical properties call rrtmgp_lw_mcica_subcol_gen_run(dolw, ktoprad, & kdist_lw, nlwbands, nlwgpts, ncol, pver, nlaycam, nlwgpts, & - state%pmid, cldf, tauc, cloud_lw, errmsg, errflg ) + state%pmid(:ncol,:), cldf, tauc, cloud_lw, errmsg, errflg ) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if @@ -1289,7 +1295,7 @@ subroutine radiation_tend( & call rrtmgp_get_gas_mmrs(icall, state, pbuf, nlay, gas_mmrs) ! Set gas volume mixing ratios for this call in gas_concs_lw - call rrtmgp_lw_gas_optics_pre_run(gas_mmrs, state%pmid, state%pint, nlay, ncol, gaslist, & + call rrtmgp_lw_gas_optics_pre_run(gas_mmrs, state%pmid(:ncol,:), state%pint(:ncol,:), nlay, ncol, gaslist, & idxday, pverp, ktoprad, ktopcam, dolw, nradgas, gas_concs_lw, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) @@ -1398,8 +1404,8 @@ subroutine radiation_tend( & end if ! if (dosw .or. dolw) then ! Calculate dry static energy if LW calc or SW calc wasn't done; needed before calling radheat_run - call rrtmgp_dry_static_energy_tendency_run(ncol, state%pdel, (.not. dosw), (.not. dolw), & - qrs, qrl, errmsg, errflg) + call rrtmgp_dry_static_energy_tendency_run(state%pdel(:ncol,:), (.not. dosw), (.not. dolw), & + qrs(:ncol,:), qrl(:ncol,:), errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if @@ -1427,9 +1433,11 @@ subroutine radiation_tend( & deallocate(rd) end if + cam_out%netsw(:) = 0._r8 + ! Calculate radiative heating (Q*dp), set netsw flux, and do object cleanup - call rrtmgp_post_run(ncol, qrs, qrl, fsns, state%pdel, atm_optics_sw, cloud_sw, aer_sw, & - fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, cam_out%netsw, errmsg, errflg) + call rrtmgp_post_run(qrs(:ncol,:), qrl(:ncol,:), fsns(:ncol), state%pdel(:ncol,:), atm_optics_sw, cloud_sw, aer_sw, & + fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, cam_out%netsw(:ncol), errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if From 05025958adfa262d3ee92740095a5348a3433583 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Thu, 10 Apr 2025 17:04:17 -0600 Subject: [PATCH 15/17] handle conditionally present pbuf fields --- src/physics/rrtmgp/radiation.F90 | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 1cad027e7c..c0a97a0d6f 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -20,7 +20,7 @@ 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_out use radconstants, only: nradgas, gasnamelength, nswbands, nlwbands, & gaslist, radconstants_init @@ -875,6 +875,8 @@ subroutine radiation_tend( & 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), pointer :: cldfsnow_in(:,:) ! Cloud fraction of just "snow clouds", subset + real(r8), pointer :: cldfgrau_in(:,:) ! Cloud fraction of just "graupel clouds", subset real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction real(r8) :: cld_lw_abs(nlwbands,state%ncol,pver) ! Cloud absorption optics depth real(r8) :: snow_lw_abs(nlwbands,state%ncol,pver) ! Snow absorption optics depth @@ -1112,6 +1114,17 @@ subroutine radiation_tend( & call handle_allocate_error(istat, sub, 'gas_mmrs, message: '//errmsg) end if + if (associated(cldfgrau)) then + cldfgrau_in => cldfgrau(:ncol,:) + else + cldfgrau_in => null() + end if + + if (associated(cldfsnow)) then + cldfsnow_in => cldfsnow(:ncol,:) + else + cldfsnow_in => null() + end if ! Prepare state variables, daylit columns, albedos for RRTMGP ! Also calculate modified cloud fraction call rrtmgp_inputs_run(dosw, dolw, associated(cldfsnow), associated(cldfgrau), & @@ -1121,7 +1134,7 @@ subroutine radiation_tend( & pint_day, coszrs_day, alb_dir, alb_dif, cam_in%lwup(:ncol), stebol, & ncol, ktopcam, ktoprad, nswbands, cam_in%asdir(:ncol), cam_in%asdif(:ncol), & sw_low_bounds, sw_high_bounds, cam_in%aldir(:ncol), cam_in%aldif(:ncol), nlay, & - pverp, pver, cld(:ncol,:), cldfsnow(:ncol,:), cldfgrau(:ncol,:), & + pverp, pver, cld(:ncol,:), cldfsnow_in, cldfgrau_in, & graupel_in_rad, gasnamelength, gaslist, gas_concs_lw, aer_lw, atm_optics_lw, & kdist_lw, sources_lw, aer_sw, atm_optics_sw, gas_concs_sw, & errmsg, errflg) @@ -1264,8 +1277,8 @@ subroutine radiation_tend( & do_snow = associated(cldfsnow) ! Set cloud optical properties in cloud_lw object. - call rrtmgp_lw_cloud_optics_run(dolw, ncol, nlay, nlaycam, cld(:ncol,:), cldfsnow(:ncol,:), & - cldfgrau(:ncol,:), cldfprime(:ncol,:), graupel_in_rad, kdist_lw, cloud_lw, lambda(:ncol,:), & + call rrtmgp_lw_cloud_optics_run(dolw, ncol, nlay, nlaycam, cld(:ncol,:), cldfsnow_in, & + cldfgrau_in, cldfprime(:ncol,:), graupel_in_rad, kdist_lw, cloud_lw, lambda(:ncol,:), & mu(:ncol,:), iclwp(:ncol,:), iciwp(:ncol,:), dei(:ncol,:), icswp(:ncol,:), des(:ncol,:), & icgrauwp(:ncol,:), degrau(:ncol,:), nlwbands, do_snow, do_graupel, pver, & ktopcam, tauc, cldf, cld_lw_abs, snow_lw_abs, grau_lw_abs, errmsg, errflg) From 42636a1bd164bd701d8079e1783a7f5e0502001a Mon Sep 17 00:00:00 2001 From: peverwhee Date: Tue, 22 Apr 2025 11:17:20 -0600 Subject: [PATCH 16/17] fix interface bug; remove unnecessary argument from cloud optics scheme --- src/physics/rrtmgp/radiation.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index c0a97a0d6f..5f840e9a60 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1273,12 +1273,12 @@ subroutine radiation_tend( & call pbuf_get_field(pbuf, degrau_idx, degrau) end if - do_graupel = ((icgrauwp_idx > 0) .and. (degrau_idx > 0) .and. associated(cldfgrau)) + do_graupel = ((icgrauwp_idx > 0) .and. (degrau_idx > 0) .and. associated(cldfgrau)) .and. graupel_in_rad do_snow = associated(cldfsnow) ! Set cloud optical properties in cloud_lw object. call rrtmgp_lw_cloud_optics_run(dolw, ncol, nlay, nlaycam, cld(:ncol,:), cldfsnow_in, & - cldfgrau_in, cldfprime(:ncol,:), graupel_in_rad, kdist_lw, cloud_lw, lambda(:ncol,:), & + cldfgrau_in, cldfprime(:ncol,:), kdist_lw, cloud_lw, lambda(:ncol,:), & mu(:ncol,:), iclwp(:ncol,:), iciwp(:ncol,:), dei(:ncol,:), icswp(:ncol,:), des(:ncol,:), & icgrauwp(:ncol,:), degrau(:ncol,:), nlwbands, do_snow, do_graupel, pver, & ktopcam, tauc, cldf, cld_lw_abs, snow_lw_abs, grau_lw_abs, errmsg, errflg) @@ -1305,6 +1305,7 @@ subroutine radiation_tend( & if (active_calls(icall)) then ! Grab the gas mass mixing ratios from rad_constituents + gas_mmrs = 0._r8 call rrtmgp_get_gas_mmrs(icall, state, pbuf, nlay, gas_mmrs) ! Set gas volume mixing ratios for this call in gas_concs_lw @@ -1342,7 +1343,7 @@ subroutine radiation_tend( & !$acc emis_sfc) & !$acc copy(flwc%fluxes, flwc%fluxes%flux_net, flwc%fluxes%flux_up, flwc%fluxes%flux_dn, & !$acc flw, flw%fluxes%flux_net, flw%fluxes%flux_up, flw%fluxes%flux_dn) - call rrtmgp_lw_main_run(dolw, dolw, .true., .false., .false., & + call rrtmgp_lw_main_run(dolw, dolw, .false., .false., .false., & 0, ncol, 1, ncol, atm_optics_lw, & cloud_lw, top_at_1, sources_lw, emis_sfc, kdist_lw, & aer_lw, fluxlwup_jac, lw_ds, flwc, flw, errmsg, errflg) From 6c6fa44fbb6ab141211418139efe7230730c4f83 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Tue, 22 Apr 2025 11:34:49 -0600 Subject: [PATCH 17/17] update atmospheric physics hash --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 19cb74e4c7..3492317cc6 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,7 +36,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/peverwhee/atmospheric_physics - fxtag = 032a2520b657774b93dc661ccab24aa677bcf16c + fxtag = 49e6ec240f53dad382602d4b325d9198d8b399fc fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics