From 247774ecc307360ea9d9f48a6565f4bccf48a3ef Mon Sep 17 00:00:00 2001 From: peverwhee Date: Mon, 10 Feb 2025 09:47:37 -0700 Subject: [PATCH 01/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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/27] 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 From 47922f03f93080fb868d3eef3b0bc0fc888ae3c0 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Tue, 13 May 2025 16:33:19 -0600 Subject: [PATCH 18/27] update hash; add interstitial q variables --- .gitmodules | 2 +- src/physics/rrtmgp/radiation.F90 | 21 +++++++++++++-------- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/.gitmodules b/.gitmodules index 3492317cc6..2e005c1193 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,7 +36,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/peverwhee/atmospheric_physics - fxtag = 49e6ec240f53dad382602d4b325d9198d8b399fc + fxtag = 665793dee483118e86437e301f257f87beb9f8c1 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 5f840e9a60..0f8a073e96 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -881,8 +881,10 @@ subroutine radiation_tend( & 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 :: qrs(:,:) ! shortwave radiative heating rate adjusted by air pressure thickness + real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate adjusted by air pressure thickness + real(r8) :: qrs_prime(pcols, pver) ! shortwave heating rate + real(r8) :: qrl_prime(pcols, pver) ! longwave heating rate real(r8), pointer :: fsds(:) ! Surface solar down flux real(r8), pointer :: fsns(:) ! Surface solar absorbed flux real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top @@ -1417,9 +1419,12 @@ subroutine radiation_tend( & end if ! docosp end if ! if (dosw .or. dolw) then + qrs_prime = qrs + qrl_prime = qrl + ! 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(state%pdel(:ncol,:), (.not. dosw), (.not. dolw), & - qrs(:ncol,:), qrl(:ncol,:), errmsg, errflg) + qrs(:ncol,:), qrl(:ncol,:), qrs_prime(:ncol,:), qrl_prime(:ncol,:), errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if @@ -1430,14 +1435,14 @@ subroutine radiation_tend( & ! Compute net radiative heating tendency. Note that the WACCM version ! of radheat_tend merges upper atmosphere heating rates with those calculated ! by RRTMGP. - call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & + call radheat_tend(state, pbuf, ptend, qrl_prime, qrs_prime, fsns, & fsnt, flns, flnt, cam_in%asdir, net_flx) if (write_output) then ! Compute heating rate for dtheta/dt do k = 1, pver do i = 1, ncol - ftem(i,k) = (qrs(i,k) + qrl(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa + ftem(i,k) = (qrs_prime(i,k) + qrl_prime(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa end do end do call outfld('HR', ftem, pcols, lchnk) @@ -1450,8 +1455,8 @@ subroutine radiation_tend( & cam_out%netsw(:) = 0._r8 ! Calculate radiative heating (Q*dp), set netsw flux, and do object cleanup - 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) + call rrtmgp_post_run(qrs_prime(:ncol,:), qrl_prime(:ncol,:), fsns(:ncol), state%pdel(:ncol,:), atm_optics_sw, cloud_sw, aer_sw, & + fsw, fswc, sources_lw, cloud_lw, aer_lw, flw, flwc, qrs(:ncol,:), qrl(:ncol,:), cam_out%netsw(:ncol), errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) end if @@ -2027,7 +2032,7 @@ subroutine coefs_init(coefs_file, available_gases, kdist) ierr = pio_get_var(fh, vid, temp_ref_t) if (ierr /= PIO_NOERR) call endrun(sub//': error reading absorption_coefficient_ref_T') - ! standard spectroscopic reference pressure [hPa] + ! standard spectroscopic reference pressure [Pa] ierr = pio_inq_varid(fh, 'absorption_coefficient_ref_P', vid) if (ierr /= PIO_NOERR) call endrun(sub//': absorption_coefficient_ref_P not found') ierr = pio_get_var(fh, vid, temp_ref_p) From 78bff29ce7e5a45f31c05f79ca1701ebc2d038be Mon Sep 17 00:00:00 2001 From: peverwhee Date: Tue, 20 May 2025 13:46:09 -0600 Subject: [PATCH 19/27] update hash --- .gitmodules | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitmodules b/.gitmodules index 71a9cc0dc5..70e4c3b1b9 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,7 +36,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/peverwhee/atmospheric_physics - fxtag = 90ffd79eb8410cd5387e86e0ef01f9306de8998c + fxtag = 787d876557a3f5ae5ac763ad11a752e034b32456 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics From 1232b5bbdb5eda93e4ab2abf223dfabd5afd3145 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Sun, 8 Jun 2025 22:06:31 -0600 Subject: [PATCH 20/27] address review comments --- .gitmodules | 4 ++-- src/physics/cam/cloud_rad_props.F90 | 21 ++++++--------------- src/physics/cam/radheat.F90 | 5 +++++ src/physics/rrtmgp/rad_solar_var.F90 | 3 +++ 4 files changed, 16 insertions(+), 17 deletions(-) diff --git a/.gitmodules b/.gitmodules index 4569bc04eb..c2a6543e4b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,7 +36,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/peverwhee/atmospheric_physics - fxtag = 787d876557a3f5ae5ac763ad11a752e034b32456 + fxtag = 44ace8d60c155caae3c5abe55fddc78f826c2002 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics @@ -186,7 +186,7 @@ fxDONOTUSEurl = https://github.com/NCAR/ParallelIO [submodule "cice"] path = components/cice url = https://github.com/ESCOMP/CESM_CICE -fxtag = cesm3_cice6_6_0_6 +fxtag = cesm3_cice6_6_0_8 fxrequired = ToplevelRequired fxDONOTUSEurl = https://github.com/ESCOMP/CESM_CICE diff --git a/src/physics/cam/cloud_rad_props.F90 b/src/physics/cam/cloud_rad_props.F90 index 894f4a1356..e0b8263e63 100644 --- a/src/physics/cam/cloud_rad_props.F90 +++ b/src/physics/cam/cloud_rad_props.F90 @@ -85,6 +85,7 @@ subroutine cloud_rad_props_init(nmu_out, nlambda_out, n_g_d_out, & use spmd_utils, only: masterproc use ioFileMod, only: getfil use error_messages, only: handle_ncerr + use cam_abortutils, only: handle_allocate_error #if ( defined SPMD ) use mpishorthand #endif @@ -296,29 +297,19 @@ subroutine cloud_rad_props_init(nmu_out, nlambda_out, n_g_d_out, & 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 + call handle_allocate_error(ierr, sub, 'abs_lw_liq_out') 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 + call handle_allocate_error(ierr, sub, 'abs_lw_ice_out') 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 + call handle_allocate_error(ierr, sub, 'g_mu_out') 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 + call handle_allocate_error(ierr, sub, 'g_lambda_out') 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 + call handle_allocate_error(ierr, sub, 'g_d_eff_out') g_d_eff_out = g_d_eff return diff --git a/src/physics/cam/radheat.F90 b/src/physics/cam/radheat.F90 index 15ab38a843..da5acf530a 100644 --- a/src/physics/cam/radheat.F90 +++ b/src/physics/cam/radheat.F90 @@ -83,6 +83,7 @@ subroutine radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & use metdata, only: met_rlx, met_srf_feedback #endif use calculate_net_heating, only: calculate_net_heating_run + use cam_abortutils, only: endrun !----------------------------------------------------------------------- ! Compute net radiative heating from qrs and qrl, and the associated net ! boundary flux. @@ -137,6 +138,10 @@ subroutine radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & flnt, .false., net_flx(:ncol), errmsg, errflg) #endif + if (errflg /= 0) then + call endrun('ERROR - failure during calculate_net_heating_run. Message: "'//errmsg//'"') + end if + end subroutine radheat_tend !================================================================================================ diff --git a/src/physics/rrtmgp/rad_solar_var.F90 b/src/physics/rrtmgp/rad_solar_var.F90 index de09ad84a4..bda38e2543 100644 --- a/src/physics/rrtmgp/rad_solar_var.F90 +++ b/src/physics/rrtmgp/rad_solar_var.F90 @@ -58,6 +58,9 @@ subroutine rad_solar_var_init(nswbands) end if call get_sw_spectral_boundaries_ccpp(radbinmin, radbinmax, 'nm', errmsg, errflg) + if (errflg /= 0) then + call endrun('rad_solar_var_init: Error during get_sw_spectral_boundaries_ccpp - message: "'//errmsg//'"') + end if ! 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 From 30ac479382412620c323ed00333cf29b4731d2ee Mon Sep 17 00:00:00 2001 From: peverwhee Date: Mon, 16 Jun 2025 11:43:54 -0600 Subject: [PATCH 21/27] subset arguments to ncol --- src/physics/cam/radheat.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/physics/cam/radheat.F90 b/src/physics/cam/radheat.F90 index da5acf530a..bac3dc4046 100644 --- a/src/physics/cam/radheat.F90 +++ b/src/physics/cam/radheat.F90 @@ -131,11 +131,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(:ncol,:), qrl(:ncol,:), qrs(:ncol,:), fsns, fsnt, flns, & - flnt, .true., net_flx(:ncol), errmsg, errflg) + call calculate_net_heating_run(ncol, ptend%s(:ncol,:), qrl(:ncol,:), qrs(:ncol,:), fsns(:ncol), & + fsnt(:ncol), flns(:ncol), flnt(:ncol), .true., net_flx(:ncol), errmsg, errflg) #else - call calculate_net_heating_run(ncol, ptend%s(:ncol,:), qrl(:ncol,:), qrs(:ncol,:), fsns, fsnt, flns, & - flnt, .false., net_flx(:ncol), errmsg, errflg) + call calculate_net_heating_run(ncol, ptend%s(:ncol,:), qrl(:ncol,:), qrs(:ncol,:), fsns(:ncol), & + fsnt(:ncol), flns(:ncol), flnt(:ncol), .false., net_flx(:ncol), errmsg, errflg) #endif if (errflg /= 0) then From c7f1db223027b27680f28cd1fa314d33bcdeac1a Mon Sep 17 00:00:00 2001 From: peverwhee Date: Mon, 16 Jun 2025 11:49:11 -0600 Subject: [PATCH 22/27] address review comments --- src/physics/rrtmgp/radiation.F90 | 5 ++--- src/physics/rrtmgp/rrtmgp_inputs_cam.F90 | 3 +++ 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 603a34976d..2304f0de0a 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -151,7 +151,6 @@ module radiation 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) ! chunk indices of daylight columns @@ -398,9 +397,9 @@ function radiation_do(op) nstep = get_nstep() select case (op) - case ('sw') ! do a shortwave heating calc this timestep? + case ('sw') ! Set radiation_do to true if doing a shortwave heating calc this timestep call radiation_do_ccpp(op, nstep, iradsw, irad_always, radiation_do, errmsg, errcode) - case ('lw') ! do a longwave heating calc this timestep? + case ('lw') ! Set radiation_do to true if doing a longwave heating calc this timestep call radiation_do_ccpp(op, nstep, iradlw, irad_always, radiation_do, errmsg, errcode) case default call endrun('radiation_do: unknown operation:'//op) diff --git a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 index 4c65ffbb69..7dcf3df550 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 @@ -105,6 +105,9 @@ 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) + if (errflg /= 0) then + call endrun('rrtmgp_inputs_cam_init: error during get_sw_spectral_boundaries_ccpp - message: '//errmsg) + end if end subroutine rrtmgp_inputs_cam_init From fe44371f830417ce3f30ded681dc1fdf5844f3f3 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Tue, 17 Jun 2025 12:23:51 -0600 Subject: [PATCH 23/27] take another stab at the open acc directives --- src/physics/rrtmgp/radiation.F90 | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index 2304f0de0a..fe8fa32252 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -1179,7 +1179,7 @@ subroutine radiation_tend( & ! Compute the gas optics (stored in atm_optics_sw). ! toa_flux is the reference solar source from RRTMGP data. - !$acc data copyin(kdist_sw%gas_props,pmid_day,pint_day,t_day,gas_concs_sw%gas_concs) & + !$acc data copyin(kdist_sw,kdist_sw%gas_props,pmid_day,pint_day,t_day,gas_concs_sw,gas_concs_sw%gas_concs) & !$acc copy(atm_optics_sw%optical_props) & !$acc copyout(toa_flux) errmsg = kdist_sw%gas_props%gas_optics( & @@ -1204,14 +1204,14 @@ subroutine radiation_tend( & ! Increment the gas optics (in atm_optics_sw) by the aerosol optics in aer_sw. !$acc data copyin(coszrs_day, toa_flux, alb_dir, alb_dif, & - !$acc atm_optics_sw%optical_props, atm_optics_sw%optical_props%tau, & + !$acc atm_optics_sw, atm_optics_sw%optical_props, atm_optics_sw%optical_props%tau, & !$acc atm_optics_sw%optical_props%ssa, atm_optics_sw%optical_props%g, & - !$acc aer_sw%optical_props, aer_sw%optical_props%tau, & + !$acc aer_sw, aer_sw%optical_props, aer_sw%optical_props%tau, & !$acc aer_sw%optical_props%ssa, aer_sw%optical_props%g, & - !$acc cloud_sw%optical_props, cloud_sw%optical_props%tau, & + !$acc cloud_sw, cloud_sw%optical_props, cloud_sw%optical_props%tau, & !$acc cloud_sw%optical_props%ssa, cloud_sw%optical_props%g) & - !$acc copy(fswc%fluxes, fswc%fluxes%flux_net,fswc%fluxes%flux_up,fswc%fluxes%flux_dn, & - !$acc fsw%fluxes, fsw%fluxes%flux_net, fsw%fluxes%flux_up, fsw%fluxes%flux_dn) + !$acc copy(fswc, fswc%fluxes, fswc%fluxes%flux_net,fswc%fluxes%flux_up,fswc%fluxes%flux_dn, & + !$acc fsw, fsw%fluxes, fsw%fluxes%flux_net, fsw%fluxes%flux_up, fsw%fluxes%flux_dn) errmsg = aer_sw%optical_props%increment(atm_optics_sw%optical_props) call stop_on_err(errmsg, sub, 'aer_sw%optical_props%increment') @@ -1317,8 +1317,8 @@ subroutine radiation_tend( & end if ! Compute the gas optics and Planck sources. - !$acc data copyin(kdist_lw%gas_props, pmid_rad, pint_rad, & - !$acc t_rad, t_sfc, gas_concs_lw%gas_concs) & + !$acc data copyin(kdist_lw,kdist_lw%gas_props, pmid_rad, pint_rad, & + !$acc t_rad, t_sfc, gas_concs_lw, gas_concs_lw%gas_concs) & !$acc copy(atm_optics_lw%optical_props, atm_optics_lw%optical_props%tau, & !$acc sources_lw%sources, sources_lw%sources%lay_source, & !$acc sources_lw%sources%sfc_source, sources_lw%sources%lev_source_inc, & @@ -1335,15 +1335,16 @@ subroutine radiation_tend( & call rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw) ! Call the main rrtmgp_lw driver - !$acc data copyin(atm_optics_lw%optical_props, atm_optics_lw%optical_props%tau, & - !$acc aer_lw%optical_props, aer_lw%optical_props%tau, & - !$acc cloud_lw%optical_props, cloud_lw%optical_props%tau, & - !$acc sources_lw%sources, sources_lw%sources%lay_source, & + !$acc data copyin(atm_optics_lw, atm_optics_lw%optical_props, atm_optics_lw%optical_props%tau, & + !$acc aer_lw, aer_lw%optical_props, aer_lw%optical_props%tau, & + !$acc cloud_lw, cloud_lw%optical_props, cloud_lw%optical_props%tau, & + !$acc sources_lw, sources_lw%sources, sources_lw%sources%lay_source, & !$acc sources_lw%sources%sfc_source, sources_lw%sources%lev_source_inc, & !$acc sources_lw%sources%lev_source_dec, sources_lw%sources%sfc_source_Jac, & !$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) + !$acc copy(flwc, flwc%fluxes, flwc%fluxes%flux_net, flwc%fluxes%flux_up, flwc%fluxes%flux_dn, & + !$acc flw, flw%fluxes, flw%fluxes%flux_net, flw%fluxes%flux_up, flw%fluxes%flux_dn, & + !$acc lw_ds) 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, & From 13d9de086db757f65cd7f51e2b2d7a0047a3ed81 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Tue, 17 Jun 2025 12:35:14 -0600 Subject: [PATCH 24/27] fixes to appease the nag compiler; update atmos_phys hash --- .gitmodules | 2 +- src/atmos_phys | 2 +- src/physics/rrtmgp/radiation.F90 | 8 ++++++-- src/physics/rrtmgp/rrtmgp_inputs_cam.F90 | 2 +- 4 files changed, 9 insertions(+), 5 deletions(-) diff --git a/.gitmodules b/.gitmodules index c2e51a1067..4f9d70224b 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,7 +36,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/peverwhee/atmospheric_physics - fxtag = 55295a4734ceed60fd696968c0fd31709ab9ab98 + fxtag = fccbc34924b3c5b5cd7632aeb71685c10e34351e fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics diff --git a/src/atmos_phys b/src/atmos_phys index 55295a4734..fccbc34924 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit 55295a4734ceed60fd696968c0fd31709ab9ab98 +Subproject commit fccbc34924b3c5b5cd7632aeb71685c10e34351e diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index fe8fa32252..2ba5b50f89 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -992,6 +992,7 @@ subroutine radiation_tend( & real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables + real(r8), target :: zero_variable(1,1) character(len=128) :: errmsg integer :: errflg, err @@ -1001,6 +1002,9 @@ subroutine radiation_tend( & lchnk = state%lchnk ncol = state%ncol + ! Initialize dummy zero variable + zero_variable = 0._r8 + if (present(rd_out)) then rd => rd_out write_output = .false. @@ -1118,13 +1122,13 @@ subroutine radiation_tend( & if (associated(cldfgrau)) then cldfgrau_in => cldfgrau(:ncol,:) else - cldfgrau_in => null() + cldfgrau_in => zero_variable end if if (associated(cldfsnow)) then cldfsnow_in => cldfsnow(:ncol,:) else - cldfsnow_in => null() + cldfsnow_in => zero_variable end if ! Prepare state variables, daylit columns, albedos for RRTMGP ! Also calculate modified cloud fraction diff --git a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 index 7dcf3df550..faf4d0abff 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 @@ -285,7 +285,7 @@ subroutine rrtmgp_get_gas_mmrs(icall, state, pbuf, nlay, gas_mmrs) ncol = state%ncol do i = 1, nradgas call rad_cnst_get_gas(icall, gaslist(i), state, pbuf, gas_mmr) - gas_mmrs(:,:,i) = gas_mmr + gas_mmrs(:,:,i) = gas_mmr(:ncol,:) end do end subroutine rrtmgp_get_gas_mmrs From dcbbf609ae6d856170c3f7438d8770656ab9ba37 Mon Sep 17 00:00:00 2001 From: peverwhee Date: Wed, 18 Jun 2025 17:23:15 -0600 Subject: [PATCH 25/27] update acc directives; remove redundant lowercasing --- src/physics/rrtmgp/radiation.F90 | 56 +++++++++++++++++--------------- 1 file changed, 30 insertions(+), 26 deletions(-) diff --git a/src/physics/rrtmgp/radiation.F90 b/src/physics/rrtmgp/radiation.F90 index fe8fa32252..03db075c37 100644 --- a/src/physics/rrtmgp/radiation.F90 +++ b/src/physics/rrtmgp/radiation.F90 @@ -469,7 +469,7 @@ subroutine radiation_init(pbuf2d) 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(), 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, & + idx_sw_cloudsim, idx_lw_diag, idx_lw_cloudsim, nswgpts, nlwgpts, nlayp, & nextsw_cday, get_curr_calday(), band2gpt_sw, errmsg, errflg) if (errflg /= 0) then call endrun(sub//': '//errmsg) @@ -1136,7 +1136,7 @@ subroutine radiation_tend( & 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_in, cldfgrau_in, & - graupel_in_rad, gasnamelength, gaslist, gas_concs_lw, aer_lw, atm_optics_lw, & + graupel_in_rad, gasnamelength, gaslist_lc, 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 @@ -1179,7 +1179,7 @@ subroutine radiation_tend( & ! Compute the gas optics (stored in atm_optics_sw). ! toa_flux is the reference solar source from RRTMGP data. - !$acc data copyin(kdist_sw,kdist_sw%gas_props,pmid_day,pint_day,t_day,gas_concs_sw,gas_concs_sw%gas_concs) & + !$acc data copyin(kdist_sw%gas_props,pmid_day,pint_day,t_day,gas_concs_sw%gas_concs) & !$acc copy(atm_optics_sw%optical_props) & !$acc copyout(toa_flux) errmsg = kdist_sw%gas_props%gas_optics( & @@ -1204,14 +1204,13 @@ subroutine radiation_tend( & ! Increment the gas optics (in atm_optics_sw) by the aerosol optics in aer_sw. !$acc data copyin(coszrs_day, toa_flux, alb_dir, alb_dif, & - !$acc atm_optics_sw, atm_optics_sw%optical_props, atm_optics_sw%optical_props%tau, & - !$acc atm_optics_sw%optical_props%ssa, atm_optics_sw%optical_props%g, & - !$acc aer_sw, aer_sw%optical_props, aer_sw%optical_props%tau, & - !$acc aer_sw%optical_props%ssa, aer_sw%optical_props%g, & - !$acc cloud_sw, cloud_sw%optical_props, cloud_sw%optical_props%tau, & - !$acc cloud_sw%optical_props%ssa, cloud_sw%optical_props%g) & - !$acc copy(fswc, fswc%fluxes, fswc%fluxes%flux_net,fswc%fluxes%flux_up,fswc%fluxes%flux_dn, & - !$acc fsw, fsw%fluxes, fsw%fluxes%flux_net, fsw%fluxes%flux_up, fsw%fluxes%flux_dn) + !$acc atm_optics_sw%optical_props, atm_optics_sw%optical_props%tau, atm_optics_sw%optical_props%ssa, & + !$acc atm_optics_sw%optical_props%g, aer_sw%optical_props%tau, & + !$acc aer_sw%optical_props, aer_sw%optical_props%ssa, aer_sw%optical_props%g, & + !$acc cloud_sw%optical_props, cloud_sw%optical_props%tau, cloud_sw%optical_props%ssa, & + !$acc cloud_sw%optical_props%g) & + !$acc copy(fswc%fluxes, fswc%fluxes%flux_net,fswc%fluxes%flux_up,fswc%fluxes%flux_dn, & + !$acc fsw%fluxes, fsw%fluxes%flux_net,fsw%fluxes%flux_up,fsw%fluxes%flux_dn) errmsg = aer_sw%optical_props%increment(atm_optics_sw%optical_props) call stop_on_err(errmsg, sub, 'aer_sw%optical_props%increment') @@ -1317,12 +1316,14 @@ subroutine radiation_tend( & end if ! Compute the gas optics and Planck sources. - !$acc data copyin(kdist_lw,kdist_lw%gas_props, pmid_rad, pint_rad, & - !$acc t_rad, t_sfc, gas_concs_lw, gas_concs_lw%gas_concs) & - !$acc copy(atm_optics_lw%optical_props, atm_optics_lw%optical_props%tau, & - !$acc sources_lw%sources, sources_lw%sources%lay_source, & - !$acc sources_lw%sources%sfc_source, sources_lw%sources%lev_source_inc, & - !$acc sources_lw%sources%lev_source_dec, sources_lw%sources%sfc_source_jac) + !$acc data copyin(kdist_lw%gas_props, pmid_rad, pint_rad, t_rad, & + !$acc t_sfc, gas_concs_lw%gas_concs) & + !$acc copy(atm_optics_lw%optical_props, atm_optics_lw%optical_props%tau, & + !$acc sources_lw%sources, sources_lw%sources%lay_source, & + !$acc sources_lw%sources%sfc_source, & + !$acc sources_lw%sources%lev_source_inc, & + !$acc sources_lw%sources%lev_source_dec, & + !$acc sources_lw%sources%sfc_source_jac) 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) @@ -1335,15 +1336,18 @@ subroutine radiation_tend( & call rrtmgp_set_aer_lw(icall, state, pbuf, aer_lw) ! Call the main rrtmgp_lw driver - !$acc data copyin(atm_optics_lw, atm_optics_lw%optical_props, atm_optics_lw%optical_props%tau, & - !$acc aer_lw, aer_lw%optical_props, aer_lw%optical_props%tau, & - !$acc cloud_lw, cloud_lw%optical_props, cloud_lw%optical_props%tau, & - !$acc sources_lw, sources_lw%sources, sources_lw%sources%lay_source, & - !$acc sources_lw%sources%sfc_source, sources_lw%sources%lev_source_inc, & - !$acc sources_lw%sources%lev_source_dec, sources_lw%sources%sfc_source_Jac, & - !$acc emis_sfc) & - !$acc copy(flwc, flwc%fluxes, flwc%fluxes%flux_net, flwc%fluxes%flux_up, flwc%fluxes%flux_dn, & - !$acc flw, flw%fluxes, flw%fluxes%flux_net, flw%fluxes%flux_up, flw%fluxes%flux_dn, & + !$acc data copyin(atm_optics_lw%optical_props,atm_optics_lw%optical_props%tau, & + !$acc aer_lw%optical_props,aer_lw%optical_props%tau, & + !$acc cloud_lw%optical_props, cloud_lw%optical_props%tau, & + !$acc sources_lw%sources,sources_lw%sources%lay_source, & + !$acc sources_lw%sources%sfc_source, & + !$acc sources_lw%sources%lev_source_inc, & + !$acc sources_lw%sources%lev_source_dec, & + !$acc sources_lw%sources%sfc_source_jac, & + !$acc emis_sfc) & + !$acc copy(flwc%fluxes, flwc%fluxes%flux_net, flwc%fluxes%flux_up, & + !$acc flwc%fluxes%flux_dn, flw%fluxes, flw%fluxes%flux_net, & + !$acc flw%fluxes%flux_up, flw%fluxes%flux_dn, & !$acc lw_ds) call rrtmgp_lw_main_run(dolw, dolw, .false., .false., .false., & 0, ncol, 1, ncol, atm_optics_lw, & From 1b579d09c36867002b8baede61cb287158716677 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Wed, 18 Jun 2025 17:30:07 -0600 Subject: [PATCH 26/27] address reviewer comments --- .gitmodules | 2 +- src/atmos_phys | 2 +- src/physics/cam/cloud_rad_props.F90 | 10 +++++----- src/physics/rrtmgp/radconstants.F90 | 8 ++++---- src/physics/rrtmgp/rrtmgp_inputs_cam.F90 | 4 ++-- 5 files changed, 13 insertions(+), 13 deletions(-) diff --git a/.gitmodules b/.gitmodules index 4f9d70224b..dfb565c239 100644 --- a/.gitmodules +++ b/.gitmodules @@ -36,7 +36,7 @@ [submodule "atmos_phys"] path = src/atmos_phys url = https://github.com/peverwhee/atmospheric_physics - fxtag = fccbc34924b3c5b5cd7632aeb71685c10e34351e + fxtag = 2c71e1525c2cca32cc27d4175261daada52059f3 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics diff --git a/src/atmos_phys b/src/atmos_phys index fccbc34924..2c71e1525c 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit fccbc34924b3c5b5cd7632aeb71685c10e34351e +Subproject commit 2c71e1525c2cca32cc27d4175261daada52059f3 diff --git a/src/physics/cam/cloud_rad_props.F90 b/src/physics/cam/cloud_rad_props.F90 index e0b8263e63..5d0151d0ed 100644 --- a/src/physics/cam/cloud_rad_props.F90 +++ b/src/physics/cam/cloud_rad_props.F90 @@ -296,19 +296,19 @@ subroutine cloud_rad_props_init(nmu_out, nlambda_out, n_g_d_out, & 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) + allocate(abs_lw_liq_out(nmu,nlambda,nlwbands), stat=ierr) call handle_allocate_error(ierr, sub, 'abs_lw_liq_out') abs_lw_liq_out = abs_lw_liq - allocate(abs_lw_ice_out(n_g_d,nlwbands), stat=ierr, errmsg=errmsg) + allocate(abs_lw_ice_out(n_g_d,nlwbands), stat=ierr) call handle_allocate_error(ierr, sub, 'abs_lw_ice_out') abs_lw_ice_out = abs_lw_ice - allocate(g_mu_out(nmu), stat=ierr, errmsg=errmsg) + allocate(g_mu_out(nmu), stat=ierr) call handle_allocate_error(ierr, sub, 'g_mu_out') g_mu_out = g_mu - allocate(g_lambda_out(nmu,nlambda), stat=ierr, errmsg=errmsg) + allocate(g_lambda_out(nmu,nlambda), stat=ierr) call handle_allocate_error(ierr, sub, 'g_lambda_out') g_lambda_out = g_lambda - allocate(g_d_eff_out(n_g_d), stat=ierr, errmsg=errmsg) + allocate(g_d_eff_out(n_g_d), stat=ierr) call handle_allocate_error(ierr, sub, 'g_d_eff_out') g_d_eff_out = g_d_eff return diff --git a/src/physics/rrtmgp/radconstants.F90 b/src/physics/rrtmgp/radconstants.F90 index 0edf9772e2..815ffafd45 100644 --- a/src/physics/rrtmgp/radconstants.F90 +++ b/src/physics/rrtmgp/radconstants.F90 @@ -5,8 +5,6 @@ module radconstants use shr_kind_mod, only: r8 => shr_kind_r8 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 @@ -72,7 +70,8 @@ subroutine radconstants_init(idx_sw_diag_in, idx_nir_diag_in, idx_uv_diag_in, id end subroutine radconstants_init !========================================================================================= - subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) +subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) + use radiation_utils, only: get_sw_spectral_boundaries_ccpp ! provide spectral boundaries of each shortwave band @@ -89,11 +88,12 @@ subroutine get_sw_spectral_boundaries(low_boundaries, high_boundaries, units) call endrun(errmsg) end if - end subroutine get_sw_spectral_boundaries +end subroutine get_sw_spectral_boundaries !========================================================================================= subroutine get_lw_spectral_boundaries(low_boundaries, high_boundaries, units) + use radiation_utils, only: get_lw_spectral_boundaries_ccpp ! provide spectral boundaries of each longwave band diff --git a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 index faf4d0abff..b104275715 100644 --- a/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 +++ b/src/physics/rrtmgp/rrtmgp_inputs_cam.F90 @@ -170,7 +170,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_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 integer, optional, intent(in) :: idxday(:) ! indices of daylight columns in a chunk @@ -338,7 +338,7 @@ 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) :: nswgpts ! number of shortwave g-points integer, intent(in) :: nnite ! number of night columns integer, intent(in) :: idxnite(pcols) ! indices of night columns in the chunk From 31f5513ab1a02c7c99c63f73de03a527849c4e73 Mon Sep 17 00:00:00 2001 From: Courtney Peverley Date: Wed, 18 Jun 2025 17:33:11 -0600 Subject: [PATCH 27/27] update git-fleximod --- .lib/CODE_OF_CONDUCT.md | 107 +++++ .lib/License | 20 + .lib/README.md | 108 +++++ .lib/doc/Makefile | 20 + .lib/doc/conf.py | 26 ++ .lib/doc/index.rst | 24 + .lib/doc/make.bat | 35 ++ .lib/escomp_install | 25 + .lib/git-fleximod/pyproject.toml | 3 +- .lib/git-fleximod/tbump.toml | 2 +- .lib/git_fleximod/__init__.py | 0 .lib/git_fleximod/cli.py | 151 ++++++ .lib/git_fleximod/git_fleximod.py | 370 +++++++++++++++ .lib/git_fleximod/gitinterface.py | 115 +++++ .lib/git_fleximod/gitmodules.py | 97 ++++ .lib/git_fleximod/lstripreader.py | 43 ++ .lib/git_fleximod/metoflexi.py | 236 ++++++++++ .lib/git_fleximod/submodule.py | 455 ++++++++++++++++++ .lib/git_fleximod/utils.py | 365 +++++++++++++++ .lib/poetry.lock | 693 ++++++++++++++++++++++++++++ .lib/pyproject.toml | 42 ++ .lib/tbump.toml | 43 ++ .lib/tests/__init__.py | 3 + .lib/tests/conftest.py | 150 ++++++ .lib/tests/test_a_import.py | 8 + .lib/tests/test_b_update.py | 26 ++ .lib/tests/test_c_required.py | 30 ++ .lib/tests/test_d_complex.py | 66 +++ .lib/tests/test_e_complex_update.py | 69 +++ 29 files changed, 3330 insertions(+), 2 deletions(-) create mode 100644 .lib/CODE_OF_CONDUCT.md create mode 100644 .lib/License create mode 100644 .lib/README.md create mode 100644 .lib/doc/Makefile create mode 100644 .lib/doc/conf.py create mode 100644 .lib/doc/index.rst create mode 100644 .lib/doc/make.bat create mode 100644 .lib/escomp_install create mode 100644 .lib/git_fleximod/__init__.py create mode 100644 .lib/git_fleximod/cli.py create mode 100755 .lib/git_fleximod/git_fleximod.py create mode 100644 .lib/git_fleximod/gitinterface.py create mode 100644 .lib/git_fleximod/gitmodules.py create mode 100644 .lib/git_fleximod/lstripreader.py create mode 100755 .lib/git_fleximod/metoflexi.py create mode 100644 .lib/git_fleximod/submodule.py create mode 100644 .lib/git_fleximod/utils.py create mode 100644 .lib/poetry.lock create mode 100644 .lib/pyproject.toml create mode 100644 .lib/tbump.toml create mode 100644 .lib/tests/__init__.py create mode 100644 .lib/tests/conftest.py create mode 100644 .lib/tests/test_a_import.py create mode 100644 .lib/tests/test_b_update.py create mode 100644 .lib/tests/test_c_required.py create mode 100644 .lib/tests/test_d_complex.py create mode 100644 .lib/tests/test_e_complex_update.py diff --git a/.lib/CODE_OF_CONDUCT.md b/.lib/CODE_OF_CONDUCT.md new file mode 100644 index 0000000000..84f2925bba --- /dev/null +++ b/.lib/CODE_OF_CONDUCT.md @@ -0,0 +1,107 @@ +# Contributor Code of Conduct +_The Contributor Code of Conduct is for participants in our software projects and community._ + +## Our Pledge +We, as contributors, creators, stewards, and maintainers (participants), of **git-fleximod** pledge to make participation in +our software, system or hardware project and community a safe, productive, welcoming and inclusive experience for everyone. +All participants are required to abide by this Code of Conduct. +This includes respectful treatment of everyone regardless of age, body size, disability, ethnicity, gender identity or expression, +level of experience, nationality, political affiliation, veteran status, pregnancy, genetic information, physical appearance, race, +religion, or sexual orientation, as well as any other characteristic protected under applicable US federal or state law. + +## Our Standards +Examples of behaviors that contribute to a positive environment include: + +* All participants are treated with respect and consideration, valuing a diversity of views and opinions +* Be considerate, respectful, and collaborative +* Communicate openly with respect for others, critiquing ideas rather than individuals and gracefully accepting criticism +* Acknowledging the contributions of others +* Avoid personal attacks directed toward other participants +* Be mindful of your surroundings and of your fellow participants +* Alert UCAR staff and suppliers/vendors if you notice a dangerous situation or someone in distress +* Respect the rules and policies of the project and venue + +Examples of unacceptable behavior include, but are not limited to: + +* Harassment, intimidation, or discrimination in any form +* Physical, verbal, or written abuse by anyone to anyone, including repeated use of pronouns other than those requested +* Unwelcome sexual attention or advances +* Personal attacks directed at other guests, members, participants, etc. +* Publishing others' private information, such as a physical or electronic address, without explicit permission +* Alarming, intimidating, threatening, or hostile comments or conduct +* Inappropriate use of nudity and/or sexual images +* Threatening or stalking anyone, including a participant +* Other conduct which could reasonably be considered inappropriate in a professional setting + +## Scope +This Code of Conduct applies to all spaces managed by the Project whether they be physical, online or face-to-face. +This includes project code, code repository, associated web pages, documentation, mailing lists, project websites and wiki pages, +issue tracker, meetings, telecons, events, project social media accounts, and any other forums created by the project team which the +community uses for communication. +In addition, violations of this Code of Conduct outside these spaces may affect a person's ability to participate within them. +Representation of a project may be further defined and clarified by project maintainers. + +## Community Responsibilities +Everyone in the community is empowered to respond to people who are showing unacceptable behavior. +They can talk to them privately or publicly. +Anyone requested to stop unacceptable behavior is expected to comply immediately. +If the behavior continues concerns may be brought to the project administrators or to any other party listed in the +[Reporting](#reporting) section below. + +## Project Administrator Responsibilities +Project administrators are responsible for clarifying the standards of acceptable behavior and are encouraged to model appropriate +behavior and provide support when people in the community point out inappropriate behavior. +Project administrator(s) are normally the ones that would be tasked to carry out the actions in the [Consequences](#consequences) +section below. + +Project administrators are also expected to keep this Code of Conduct updated with the main one housed at UCAR, as listed below in +the [Attribution](#attribution) section. + +## Reporting +Instances of unacceptable behavior can be brought to the attention of the project administrator(s) who may take any action as +outlined in the [Consequences](#consequences) section below. +However, making a report to a project administrator is not considered an 'official report' to UCAR. + +Instances of unacceptable behavior may also be reported directly to UCAR pursuant to [UCAR's Harassment Reporting and Complaint +Procedure](https://www2.fin.ucar.edu/procedures/hr/harassment-reporting-and-complaint-procedure), or anonymously through [UCAR's +EthicsPoint Hotline](https://www2.fin.ucar.edu/ethics/anonymous-reporting). + +Complaints received by UCAR will be handled pursuant to the procedures outlined in UCAR's Harassment Reporting and Complaint +Procedure. +Complaints to UCAR will be held as confidential as practicable under the circumstances, and retaliation against a person who +initiates a complaint or an inquiry about inappropriate behavior will not be tolerated. + +Any Contributor can use these reporting methods even if they are not directly affiliated with UCAR. +The Frequently Asked Questions (FAQ) page for reporting is [here](https://www2.fin.ucar.edu/procedures/hr/reporting-faqs). + +## Consequences +Upon receipt of a complaint, the project administrator(s) may take any action deemed necessary and appropriate under the +circumstances. +Such action can include things such as: removing, editing, or rejecting comments, commits, code, wiki edits, email, issues, and +other contributions that are not aligned to this Code of Conduct, or banning temporarily or permanently any contributor for other +behaviors that are deemed inappropriate, threatening, offensive, or harmful. +Project administrators also have the right to report violations to UCAR HR and/or UCAR's Office of Diversity, Equity and Inclusion +(ODEI), as well as a participant's home institution and/or law enforcement. +In the event an incident is reported to UCAR, UCAR will follow its Harassment Reporting and Complaint Procedure. + +## Process for Changes +All UCAR managed projects are required to adopt this Contributor Code of Conduct. +Adoption is assumed even if not expressly stated in the repository. +Projects should fill in sections where prompted with project-specific information, including, project name and adoption date. + +Projects that adopt this Code of Conduct need to stay up to date with UCAR's Contributor Code of Conduct, linked with a DOI in the +[Attribution](#attribution) section below. +Projects can make limited substantive changes to the Code of Conduct, however, the changes must be limited in scope and may not +contradict the UCAR Contributor Code of Conduct. + +## Attribution +This Code of Conduct was originally adapted from the [Contributor Covenant](http://contributor-covenant.org/version/1/4), version +1.4. +We then aligned it with the UCAR Participant Code of Conduct, which also borrows from the American Geophysical Union (AGU) Code of +Conduct. +The UCAR Participant Code of Conduct applies to both UCAR employees as well as participants in activities run by UCAR. +The original version of this for all software projects that have strong management from UCAR or UCAR staff is available on the UCAR +website at https://doi.org/10.5065/6w2c-a132. +The date that it was adopted by this project was **Feb/13/2018**. +When responding to complaints, UCAR HR and ODEI will do so based on the latest published version. +Therefore, any project-specific changes should follow the [Process for Changes](#process-for-changes) section above. diff --git a/.lib/License b/.lib/License new file mode 100644 index 0000000000..88bc22515e --- /dev/null +++ b/.lib/License @@ -0,0 +1,20 @@ +Copyright 2024 NSF National Center for Atmospheric Sciences (NCAR) + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +“Software”), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/.lib/README.md b/.lib/README.md new file mode 100644 index 0000000000..53917da400 --- /dev/null +++ b/.lib/README.md @@ -0,0 +1,108 @@ +# git-fleximod + +Flexible, Enhanced Submodule Management for Git + +## Overview + +Git-fleximod is a Python-based tool that extends Git's submodule and sparse checkout capabilities, offering additional features for managing submodules in a more flexible and efficient way. + +## Installation + + If you choose to locate git-fleximod in your path you can access it via command: git fleximod + +## Usage + + Basic Usage: + git fleximod [options] + Available Commands: + status: Display the status of submodules. + update: Update submodules to the tag indicated in .gitmodules variable fxtag. + test: Make sure that fxtags and submodule hashes are consistant, + make sure that official urls (as defined by fxDONOTUSEurl) are set + make sure that fxtags are defined for all submodules + Additional Options: + See git fleximod --help for more details. + +## Supported .gitmodules Variables + + fxtag: Specify a specific tag or branch to checkout for a submodule. + fxrequired: Mark a submodule's checkout behavior, with allowed values: + - ToplevelRequired: Top-level and required (checked out only when this is the Toplevel module). + - ToplevelOptional: Top-level and optional (checked out with --optional flag if this is the Toplevel module). + - AlwaysRequired: Always required (always checked out). + - AlwaysOptional: Always optional (checked out with --optional flag). + fxsparse: Enable sparse checkout for a submodule, pointing to a file containing sparse checkout paths. + fxDONOTUSEurl: This is the url used in the test subcommand to assure that protected branches do not point to forks + **NOTE** the fxDONOTUSEurl variable is only used to identify the official project repository and should not be + changed by users. Use the url variable to change to a fork if desired. + +## Sparse Checkouts + + To enable sparse checkout for a submodule, set the fxsparse variable + in the .gitmodules file to the path of a file containing the desired + sparse checkout paths. Git-fleximod will automatically configure + sparse checkout based on this file when applicable commands are run. + See [git-sparse-checkout](https://git-scm.com/docs/git-sparse-checkout#_internalsfull_pattern_set) + for details on the format of this file. + +## Tests + + The git fleximod test action is designed to be used by, for example, github workflows + to assure that protected branches are consistant with respect to submodule hashes and fleximod fxtags + +## Examples + +Here are some common usage examples: + +Update all submodules, including optional ones: +```bash + git fleximod update --optional +``` + +Updating a specific submodule to the fxtag indicated in .gitmodules: + +```bash + git fleximod update submodule-name +``` +Example .gitmodules entry: +```ini, toml + [submodule "cosp2"] + path = src/physics/cosp2/src + url = https://github.com/CFMIP/COSPv2.0 + fxsparse = ../.cosp_sparse_checkout + fxrequired = AlwaysRequired + fxtag = v2.1.4cesm +``` +Explanation: + +This entry indicates that the submodule named cosp2 at tag v2.1.4cesm +should be checked out into the directory src/physics/cosp2/src +relative to the .gitmodules directory. It should be checked out from +the URL https://github.com/CFMIP/COSPv2.0 and use sparse checkout as +described in the file ../.cosp_sparse_checkout relative to the path +directory. It should be checked out anytime this .gitmodules entry is +read. + +Additional example: +```ini, toml + [submodule "cime"] + path = cime + url = https://github.com/jedwards4b/cime + fxrequired = ToplevelRequired + fxtag = cime6.0.198_rme01 +``` + +Explanation: + +This entry indicates that the submodule cime should be checked out +into a directory named cime at tag cime6.0.198_rme01 from the URL +https://github.com/jedwards4b/cime. This should only be done if +the .gitmodules file is at the top level of the repository clone. + +## Contributing + +We welcome contributions! Please see the CONTRIBUTING.md file for guidelines. + +## License + +Git-fleximod is released under the MIT License. diff --git a/.lib/doc/Makefile b/.lib/doc/Makefile new file mode 100644 index 0000000000..d4bb2cbb9e --- /dev/null +++ b/.lib/doc/Makefile @@ -0,0 +1,20 @@ +# Minimal makefile for Sphinx documentation +# + +# You can set these variables from the command line, and also +# from the environment for the first two. +SPHINXOPTS ?= +SPHINXBUILD ?= sphinx-build +SOURCEDIR = . +BUILDDIR = _build + +# Put it first so that "make" without argument is like "make help". +help: + @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) + +.PHONY: help Makefile + +# Catch-all target: route all unknown targets to Sphinx using the new +# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). +%: Makefile + @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) diff --git a/.lib/doc/conf.py b/.lib/doc/conf.py new file mode 100644 index 0000000000..423099eec9 --- /dev/null +++ b/.lib/doc/conf.py @@ -0,0 +1,26 @@ +# Configuration file for the Sphinx documentation builder. +# +# For the full list of built-in configuration values, see the documentation: +# https://www.sphinx-doc.org/en/master/usage/configuration.html + +# -- Project information ----------------------------------------------------- +# https://www.sphinx-doc.org/en/master/usage/configuration.html#project-information + +project = "git-fleximod" +author = "Jim Edwards " +release = "0.4.0" + +# -- General configuration --------------------------------------------------- +# https://www.sphinx-doc.org/en/master/usage/configuration.html#general-configuration + +extensions = ["sphinx_argparse_cli"] + +templates_path = ["_templates"] +exclude_patterns = ["_build", "Thumbs.db", ".DS_Store"] + + +# -- Options for HTML output ------------------------------------------------- +# https://www.sphinx-doc.org/en/master/usage/configuration.html#options-for-html-output + +html_theme = "alabaster" +html_static_path = ["_static"] diff --git a/.lib/doc/index.rst b/.lib/doc/index.rst new file mode 100644 index 0000000000..0f9c1a7f7e --- /dev/null +++ b/.lib/doc/index.rst @@ -0,0 +1,24 @@ +.. git-fleximod documentation master file, created by + sphinx-quickstart on Sat Feb 3 12:02:22 2024. + You can adapt this file completely to your liking, but it should at least + contain the root `toctree` directive. + +Welcome to git-fleximod's documentation! +======================================== + +.. toctree:: + :maxdepth: 2 + :caption: Contents: +.. module:: sphinxcontrib.autoprogram +.. sphinx_argparse_cli:: + :module: git_fleximod.cli + :func: get_parser + :prog: git-fleximod + + +Indices and tables +================== + +* :ref:`genindex` +* :ref:`modindex` +* :ref:`search` diff --git a/.lib/doc/make.bat b/.lib/doc/make.bat new file mode 100644 index 0000000000..32bb24529f --- /dev/null +++ b/.lib/doc/make.bat @@ -0,0 +1,35 @@ +@ECHO OFF + +pushd %~dp0 + +REM Command file for Sphinx documentation + +if "%SPHINXBUILD%" == "" ( + set SPHINXBUILD=sphinx-build +) +set SOURCEDIR=. +set BUILDDIR=_build + +%SPHINXBUILD% >NUL 2>NUL +if errorlevel 9009 ( + echo. + echo.The 'sphinx-build' command was not found. Make sure you have Sphinx + echo.installed, then set the SPHINXBUILD environment variable to point + echo.to the full path of the 'sphinx-build' executable. Alternatively you + echo.may add the Sphinx directory to PATH. + echo. + echo.If you don't have Sphinx installed, grab it from + echo.https://www.sphinx-doc.org/ + exit /b 1 +) + +if "%1" == "" goto help + +%SPHINXBUILD% -M %1 %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% %O% +goto end + +:help +%SPHINXBUILD% -M help %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% %O% + +:end +popd diff --git a/.lib/escomp_install b/.lib/escomp_install new file mode 100644 index 0000000000..ae782e72a4 --- /dev/null +++ b/.lib/escomp_install @@ -0,0 +1,25 @@ +#!/usr/bin/env python +# updates git-fleximod in an ESCOMP model +# this script should be run from the model root directory, it expects +# git-fleximod to already be installed with the script in bin +# and the classes in lib/python/site-packages +import sys +import shutil +import os + +from glob import iglob + +fleximod_root = sys.argv[1] +fleximod_path = os.path.join(fleximod_root,"src","git-fleximod") +if os.path.isfile(fleximod_path): + with open(fleximod_path,"r") as f: + fleximod = f.readlines() + with open(os.path.join(".","bin","git-fleximod"),"w") as f: + for line in fleximod: + f.write(line) + if "import argparse" in line: + f.write('\nsys.path.append(os.path.join(os.path.dirname(__file__),"..","lib","python","site-packages"))\n\n') + + for file in iglob(os.path.join(fleximod_root, "src", "fleximod", "*.py")): + shutil.copy(file, + os.path.join("lib","python","site-packages","fleximod",os.path.basename(file))) diff --git a/.lib/git-fleximod/pyproject.toml b/.lib/git-fleximod/pyproject.toml index 65924ff9a0..95e6076f7f 100644 --- a/.lib/git-fleximod/pyproject.toml +++ b/.lib/git-fleximod/pyproject.toml @@ -1,6 +1,6 @@ [tool.poetry] name = "git-fleximod" -version = "0.9.4" +version = "1.0.1" description = "Extended support for git-submodule and git-sparse-checkout" authors = ["Jim Edwards "] maintainers = ["Jim Edwards "] @@ -11,6 +11,7 @@ keywords = ["git", "submodule", "sparse-checkout"] packages = [ { include = "git_fleximod"}, { include = "doc"}, +{ include = "README.md"}, ] [tool.poetry.scripts] diff --git a/.lib/git-fleximod/tbump.toml b/.lib/git-fleximod/tbump.toml index be0b799d34..b20c789b6c 100644 --- a/.lib/git-fleximod/tbump.toml +++ b/.lib/git-fleximod/tbump.toml @@ -2,7 +2,7 @@ github_url = "https://github.com/jedwards4b/git-fleximod/" [version] -current = "0.9.4" +current = "1.0.1" # Example of a semver regexp. # Make sure this matches current_version before diff --git a/.lib/git_fleximod/__init__.py b/.lib/git_fleximod/__init__.py new file mode 100644 index 0000000000..e69de29bb2 diff --git a/.lib/git_fleximod/cli.py b/.lib/git_fleximod/cli.py new file mode 100644 index 0000000000..09f23db6de --- /dev/null +++ b/.lib/git_fleximod/cli.py @@ -0,0 +1,151 @@ +from pathlib import Path +import argparse, os, sys +from importlib.resources import files +from git_fleximod import utils + +__version__ = "1.0.1" + +class CustomArgumentParser(argparse.ArgumentParser): + def print_help(self, file=None): + # First print the default help message + super().print_help(file) + + # Then append the contents of README.md + candidate_paths = [ + os.path.join(sys.prefix, "share", "your-package", "README.md"), + os.path.join(os.path.dirname(__file__), "..", "README.md") # fallback for dev + ] + for path in candidate_paths: + if os.path.exists(path): + with open(path) as f: + print( f.read(), file=file) + return + print( "README.md not found.", file=file) + +def find_root_dir(filename=".gitmodules"): + """ finds the highest directory in tree + which contains a file called filename """ + try: + root = utils.execute_subprocess(["git","rev-parse", "--show-toplevel"], + output_to_caller=True ).rstrip() + except: + d = Path.cwd() + root = Path(d.root) + dirlist = [] + dl = d + while dl != root: + dirlist.append(dl) + dl = dl.parent + dirlist.append(root) + dirlist.reverse() + + for dl in dirlist: + attempt = dl / filename + if attempt.is_file(): + return str(dl) + return None + return Path(root) + +def get_parser(): + description = """ + %(prog)s manages checking out groups of gitsubmodules with additional support for Earth System Models + """ + parser = CustomArgumentParser( + description=description, formatter_class=argparse.RawDescriptionHelpFormatter + ) + + # + # user options + # + choices = ["update", "status", "test"] + parser.add_argument( + "action", + choices=choices, + default="update", + help=f"Subcommand of git-fleximod, choices are {choices[:-1]}", + ) + + parser.add_argument( + "components", + nargs="*", + help="Specific component(s) to checkout. By default, " + "all required submodules are checked out.", + ) + + parser.add_argument( + "-C", + "--path", + default=find_root_dir(), + help="Toplevel repository directory. Defaults to top git directory relative to current.", + ) + + parser.add_argument( + "-g", + "--gitmodules", + nargs="?", + default=".gitmodules", + help="The submodule description filename. " "Default: %(default)s.", + ) + + parser.add_argument( + "-x", + "--exclude", + nargs="*", + help="Component(s) listed in the gitmodules file which should be ignored.", + ) + parser.add_argument( + "-f", + "--force", + action="store_true", + default=False, + help="Override cautions and update or checkout over locally modified repository.", + ) + + parser.add_argument( + "-o", + "--optional", + action="store_true", + default=False, + help="By default only the required submodules " + "are checked out. This flag will also checkout the " + "optional submodules relative to the toplevel directory.", + ) + + parser.add_argument( + "-v", + "--verbose", + action="count", + default=0, + help="Output additional information to " + "the screen and log file. This flag can be " + "used up to two times, increasing the " + "verbosity level each time.", + ) + + parser.add_argument( + "-V", + "--version", + action="version", + version=f"%(prog)s {__version__}", + help="Print version and exit.", + ) + + # + # developer options + # + parser.add_argument( + "--backtrace", + action="store_true", + help="DEVELOPER: show exception backtraces as extra " "debugging output", + ) + + parser.add_argument( + "-d", + "--debug", + action="store_true", + default=False, + help="DEVELOPER: output additional debugging " + "information to the screen and log file.", + ) + + return parser diff --git a/.lib/git_fleximod/git_fleximod.py b/.lib/git_fleximod/git_fleximod.py new file mode 100755 index 0000000000..b3c4fece4e --- /dev/null +++ b/.lib/git_fleximod/git_fleximod.py @@ -0,0 +1,370 @@ +#!/usr/bin/env python +import sys + +MIN_PYTHON = (3, 7) +if sys.version_info < MIN_PYTHON: + sys.exit("Python %s.%s or later is required." % MIN_PYTHON) + +import os +import shutil +import logging +import textwrap +import asyncio +from git_fleximod import utils +from git_fleximod import cli +from git_fleximod.gitinterface import GitInterface +from git_fleximod.gitmodules import GitModules +from git_fleximod.submodule import Submodule + +# logger variable is global +logger = None + + +def fxrequired_allowed_values(): + return ["ToplevelRequired", "ToplevelOptional", "AlwaysRequired", "AlwaysOptional", "TopLevelRequired", "TopLevelOptional"] + + +def commandline_arguments(args=None): + parser = cli.get_parser() + + if args: + options = parser.parse_args(args) + else: + options = parser.parse_args() + + # explicitly listing a component overrides the optional flag + if options.optional or options.components: + fxrequired = fxrequired_allowed_values() + else: + fxrequired = ["ToplevelRequired", "AlwaysRequired", "TopLevelRequired"] + + action = options.action + if not action: + action = "update" + handlers = [logging.StreamHandler()] + + if options.debug: + try: + open("fleximod.log", "w") + except PermissionError: + sys.exit("ABORT: Could not write file fleximod.log") + level = logging.DEBUG + handlers.append(logging.FileHandler("fleximod.log")) + elif options.verbose: + level = logging.INFO + else: + level = logging.WARNING + # Configure the root logger + logging.basicConfig( + level=level, format="%(name)s - %(levelname)s - %(message)s", handlers=handlers + ) + + if hasattr(options, "version"): + exit() + + return ( + options.path, + options.gitmodules, + fxrequired, + options.components, + options.exclude, + options.force, + action, + ) + + +def submodule_sparse_checkout(root_dir, name, url, path, sparsefile, tag="master"): + """ + This function performs a sparse checkout of a git submodule. It does so by first creating the .git/info/sparse-checkout fileq + in the submodule and then checking out the desired tag. If the submodule is already checked out, it will not be checked out again. + Creating the sparse-checkout file first prevents the entire submodule from being checked out and then removed. This is important + because the submodule may have a large number of files and checking out the entire submodule and then removing it would be time + and disk space consuming. + + Parameters: + root_dir (str): The root directory for the git operation. + name (str): The name of the submodule. + url (str): The URL of the submodule. + path (str): The path to the submodule. + sparsefile (str): The sparse file for the submodule. + tag (str, optional): The tag to checkout. Defaults to "master". + + Returns: + None + """ + logger.info("Called sparse_checkout for {}".format(name)) + rgit = GitInterface(root_dir, logger) + superroot = git_toplevelroot(root_dir, logger) + + if superroot: + gitroot = superroot.strip() + else: + gitroot = root_dir.strip() + assert os.path.isdir(os.path.join(gitroot, ".git")) + # first create the module directory + if not os.path.isdir(os.path.join(root_dir, path)): + os.makedirs(os.path.join(root_dir, path)) + + # initialize a new git repo and set the sparse checkout flag + sprep_repo = os.path.join(root_dir, path) + sprepo_git = GitInterface(sprep_repo, logger) + if os.path.exists(os.path.join(sprep_repo, ".git")): + try: + logger.info("Submodule {} found".format(name)) + chk = sprepo_git.config_get_value("core", "sparseCheckout") + if chk == "true": + logger.info("Sparse submodule {} already checked out".format(name)) + return + except NoOptionError: + logger.debug("Sparse submodule {} not present".format(name)) + except Exception as e: + utils.fatal_error("Unexpected error {} occured.".format(e)) + + sprepo_git.config_set_value("core", "sparseCheckout", "true") + + # set the repository remote + + logger.info("Setting remote origin in {}/{}".format(root_dir, path)) + _, remotelist = sprepo_git.git_operation("remote", "-v") + if url not in remotelist: + sprepo_git.git_operation("remote", "add", "origin", url) + + topgit = os.path.join(gitroot, ".git") + + if gitroot != root_dir and os.path.isfile(os.path.join(root_dir, ".git")): + with open(os.path.join(root_dir, ".git")) as f: + gitpath = os.path.relpath( + os.path.join(root_dir, f.read().split()[1]), + start=os.path.join(root_dir, path), + ) + topgit = os.path.join(gitpath, "modules") + else: + topgit = os.path.relpath( + os.path.join(root_dir, ".git", "modules"), + start=os.path.join(root_dir, path), + ) + + with utils.pushd(sprep_repo): + if not os.path.isdir(topgit): + os.makedirs(topgit) + topgit += os.sep + name + + if os.path.isdir(os.path.join(root_dir, path, ".git")): + with utils.pushd(sprep_repo): + if os.path.isdir(os.path.join(topgit,".git")): + shutil.rmtree(os.path.join(topgit,".git")) + shutil.move(".git", topgit) + with open(".git", "w") as f: + f.write("gitdir: " + os.path.relpath(topgit)) + # assert(os.path.isdir(os.path.relpath(topgit, start=sprep_repo))) + gitsparse = os.path.abspath(os.path.join(topgit, "info", "sparse-checkout")) + if os.path.isfile(gitsparse): + logger.warning( + "submodule {} is already initialized {}".format(name, topgit) + ) + return + + with utils.pushd(sprep_repo): + if os.path.isfile(sparsefile): + shutil.copy(sparsefile, gitsparse) + + + # Finally checkout the repo + sprepo_git.git_operation("fetch", "origin", "--tags") + sprepo_git.git_operation("checkout", tag) + + print(f"Successfully checked out {name:>20} at {tag}") + rgit.config_set_value(f'submodule "{name}"', "active", "true") + rgit.config_set_value(f'submodule "{name}"', "url", url) + +def init_submodule_from_gitmodules(gitmodules, name, root_dir, logger): + path = gitmodules.get(name, "path") + url = gitmodules.get(name, "url") + assert path and url, f"Malformed .gitmodules file {path} {url}" + tag = gitmodules.get(name, "fxtag") + if not tag: + tag = gitmodules.get(name, "hash") + fxurl = gitmodules.get(name, "fxDONOTUSEurl") + fxsparse = gitmodules.get(name, "fxsparse") + fxrequired = gitmodules.get(name, "fxrequired") + return Submodule(root_dir, name, path, url, fxtag=tag, fxurl=fxurl, fxsparse=fxsparse, fxrequired=fxrequired, logger=logger) + +def submodules_status(gitmodules, root_dir, toplevel=False, depth=0): + testfails = 0 + localmods = 0 + needsupdate = 0 + wrapper = textwrap.TextWrapper(initial_indent=' '*(depth*10), width=120,subsequent_indent=' '*(depth*20)) + for name in gitmodules.sections(): + submod = init_submodule_from_gitmodules(gitmodules, name, root_dir, logger) + + result,n,l,t = submod.status() + if toplevel or not submod.toplevel(): + print(wrapper.fill(result)) + testfails += t + localmods += l + needsupdate += n + subdir = os.path.join(root_dir, submod.path) + if os.path.exists(os.path.join(subdir, ".gitmodules")): + gsubmod = GitModules(logger, confpath=subdir) + t,l,n = submodules_status(gsubmod, subdir, depth=depth+1) + if toplevel or not submod.toplevel(): + testfails += t + localmods += l + needsupdate += n + + return testfails, localmods, needsupdate + +def git_toplevelroot(root_dir, logger): + rgit = GitInterface(root_dir, logger) + _, superroot = rgit.git_operation("rev-parse", "--show-superproject-working-tree") + return superroot + +async def submodules_update(gitmodules, root_dir, requiredlist, force): + async def update_submodule(name, requiredlist, force): + submod = init_submodule_from_gitmodules(gitmodules, name, root_dir, logger) + + _, needsupdate, localmods, testfails = submod.status() + if not submod.fxrequired: + submod.fxrequired = "AlwaysRequired" + fxrequired = submod.fxrequired + allowedvalues = fxrequired_allowed_values() + assert fxrequired in allowedvalues + + superroot = git_toplevelroot(root_dir, logger) + + if ( + fxrequired + and ((superroot and "Toplevel" in fxrequired) + or fxrequired not in requiredlist) + ): + if "Optional" in fxrequired and "Optional" not in requiredlist: + if fxrequired.startswith("Always"): + print(f"Skipping optional component {name:>20}") + return # continue to next submodule + optional = "AlwaysOptional" in requiredlist + + if fxrequired in requiredlist: + await submod.update() + repodir = os.path.join(root_dir, submod.path) + if os.path.exists(os.path.join(repodir, ".gitmodules")): + # recursively handle this checkout + print(f"Recursively checking out submodules of {name}") + gitsubmodules = GitModules(submod.logger, confpath=repodir) + newrequiredlist = ["AlwaysRequired"] + if optional: + newrequiredlist.append("AlwaysOptional") + await submodules_update(gitsubmodules, repodir, newrequiredlist, force=force) + + tasks = [update_submodule(name, requiredlist, force) for name in gitmodules.sections()] + await asyncio.gather(*tasks) + +def local_mods_output(): + text = """\ + The submodules labeled with 'M' above are not in a clean state. + The following are options for how to proceed: + (1) Go into each submodule which is not in a clean state and issue a 'git status' + Either revert or commit your changes so that the submodule is in a clean state. + (2) use the --force option to git-fleximod + (3) you can name the particular submodules to update using the git-fleximod command line + (4) As a last resort you can remove the submodule (via 'rm -fr [directory]') + then rerun git-fleximod update. +""" + print(text) + +def submodules_test(gitmodules, root_dir): + """ + This function tests the git submodules based on the provided parameters. + + It first checks that fxtags are present and in sync with submodule hashes. + Then it ensures that urls are consistent with fxurls (not forks and not ssh) + and that sparse checkout files exist. + + Parameters: + gitmodules (ConfigParser): The gitmodules configuration. + root_dir (str): The root directory for the git operation. + + Returns: + int: The number of test failures. + """ + # First check that fxtags are present and in sync with submodule hashes + testfails, localmods, needsupdate = submodules_status(gitmodules, root_dir) + print("") + # Then make sure that urls are consistant with fxurls (not forks and not ssh) + # and that sparse checkout files exist + for name in gitmodules.sections(): + url = gitmodules.get(name, "url") + fxurl = gitmodules.get(name, "fxDONOTUSEurl") + fxsparse = gitmodules.get(name, "fxsparse") + path = gitmodules.get(name, "path") + fxurl = fxurl[:-4] if fxurl.endswith(".git") else fxurl + url = url[:-4] if url.endswith(".git") else url + if not fxurl or url.lower() != fxurl.lower(): + print(f"{name:>20} url {url} not in sync with required {fxurl}") + testfails += 1 + if fxsparse and not os.path.isfile(os.path.join(root_dir, path, fxsparse)): + print(f"{name:>20} sparse checkout file {fxsparse} not found") + testfails += 1 + return testfails + localmods + needsupdate + + +def main(): + ( + root_dir, + file_name, + fxrequired, + includelist, + excludelist, + force, + action, + ) = commandline_arguments() + # Get a logger for the package + global logger + logger = logging.getLogger(__name__) + + logger.info("action is {} root_dir={} file_name={}".format(action, root_dir, file_name)) + + if not root_dir or not os.path.isfile(os.path.join(root_dir, file_name)): + if root_dir: + file_path = utils.find_upwards(root_dir, file_name) + + if root_dir is None or file_path is None: + root_dir = "." + utils.fatal_error( + "No {} found in {} or any of it's parents".format(file_name, root_dir) + ) + + root_dir = os.path.dirname(file_path) + logger.info( + "root_dir is {} includelist={} excludelist={}".format( + root_dir, includelist, excludelist + ) + ) + gitmodules = GitModules( + logger, + confpath=root_dir, + conffile=file_name, + includelist=includelist, + excludelist=excludelist, + ) + if not gitmodules.sections(): + sys.exit(f"No submodule components found, root_dir={root_dir}") + retval = 0 + if action == "update": + asyncio.run(submodules_update(gitmodules, root_dir, fxrequired, force)) + elif action == "status": + tfails, lmods, updates = submodules_status(gitmodules, root_dir, toplevel=True) + if tfails + lmods + updates > 0: + print( + f" testfails = {tfails}, local mods = {lmods}, needs updates {updates}\n" + ) + if lmods > 0: + local_mods_output() + elif action == "test": + retval = submodules_test(gitmodules, root_dir) + else: + utils.fatal_error(f"unrecognized action request {action}") + return retval + + +if __name__ == "__main__": + sys.exit(main()) diff --git a/.lib/git_fleximod/gitinterface.py b/.lib/git_fleximod/gitinterface.py new file mode 100644 index 0000000000..1a736e4e98 --- /dev/null +++ b/.lib/git_fleximod/gitinterface.py @@ -0,0 +1,115 @@ +import os +import sys +from . import utils +from pathlib import Path +import asyncio + +class GitInterface: + def __init__(self, repo_path, logger): + logger.debug("Initialize GitInterface for {}".format(repo_path)) + if isinstance(repo_path, str): + self.repo_path = Path(repo_path).resolve() + elif isinstance(repo_path, Path): + self.repo_path = repo_path.resolve() + else: + raise TypeError("repo_path must be a str or Path object") + self.logger = logger + try: + import git + + self._use_module = True + try: + self.repo = git.Repo(str(self.repo_path)) # Initialize GitPython repo + except git.exc.InvalidGitRepositoryError: + self.git = git + self._init_git_repo() + msg = "Using GitPython interface to git" + except ImportError: + self._use_module = False + if not (self.repo_path / ".git").exists(): + self._init_git_repo() + msg = "Using shell interface to git" + self.logger.info(msg) + + def _git_command(self, operation, *args): + self.logger.info(operation) + if self._use_module and operation != "submodule": + try: + return getattr(self.repo.git, operation)(*args) + except Exception as e: + sys.exit(e) + else: + return ["git", "-C", str(self.repo_path), operation] + list(args) + + def _init_git_repo(self): + if self._use_module: + self.repo = self.git.Repo.init(str(self.repo_path)) + else: + command = ("git", "-C", str(self.repo_path), "init") + utils.execute_subprocess(command) + + def _git_operation_command(self, operation, args): + newargs = [] + for a in args: + # Do not use ssh interface + if isinstance(a, str): + a = a.replace("git@github.com:", "https://github.com/") + newargs.append(a) + + return self._git_command(operation, *newargs) + + # pylint: disable=unused-argument + def git_operation(self, operation, *args, **kwargs): + command = self._git_operation_command(operation, args) + if isinstance(command, list): + try: + status, output = utils.execute_subprocess(command, status_to_caller=True, output_to_caller=True) + return status, output.rstrip() + except Exception as e: + sys.exit(e) + else: + return 0, command + + # pylint: disable=unused-argument + async def git_operation_async(self, operation, *args, **kwargs): + command = self._git_operation_command(operation, args) + if isinstance(command, list): + try: + process = await asyncio.create_subprocess_exec( + *command, + stdout=asyncio.subprocess.PIPE, + stderr=asyncio.subprocess.PIPE + ) + stdout, stderr = await process.communicate() + status = process.returncode + output = stdout.decode().strip() if stdout else stderr.decode().strip() + return status, output + except Exception as e: + sys.exit(e) + else: + return 0, command + + def config_get_value(self, section, name): + if self._use_module: + config = self.repo.config_reader() + try: + val = config.get_value(section, name) + except: + val = None + return val + else: + cmd = ("git", "-C", str(self.repo_path), "config", "--get", f"{section}.{name}") + output = utils.execute_subprocess(cmd, output_to_caller=True) + return output.strip() + + def config_set_value(self, section, name, value): + if self._use_module: + with self.repo.config_writer() as writer: + if "." in section: + section = section.replace("."," \"")+'"' + writer.set_value(section, name, value) + writer.release() # Ensure changes are saved + else: + cmd = ("git", "-C", str(self.repo_path), "config", f"{section}.{name}", value) + self.logger.info(cmd) + utils.execute_subprocess(cmd, output_to_caller=True) diff --git a/.lib/git_fleximod/gitmodules.py b/.lib/git_fleximod/gitmodules.py new file mode 100644 index 0000000000..cf8b350dd6 --- /dev/null +++ b/.lib/git_fleximod/gitmodules.py @@ -0,0 +1,97 @@ +import shutil, os +from pathlib import Path +from configparser import RawConfigParser, ConfigParser +from .lstripreader import LstripReader + + +class GitModules(RawConfigParser): + def __init__( + self, + logger, + confpath=Path.cwd(), + conffile=".gitmodules", + includelist=None, + excludelist=None, + ): + """ + confpath: Path to the directory containing the .gitmodules file (defaults to the current working directory). + conffile: Name of the configuration file (defaults to .gitmodules). + includelist: Optional list of submodules to include. + excludelist: Optional list of submodules to exclude. + """ + self.logger = logger + self.logger.debug( + "Creating a GitModules object {} {} {} {}".format( + confpath, conffile, includelist, excludelist + ) + ) + super().__init__() + self.conf_file = (Path(confpath) / Path(conffile)) + if self.conf_file.exists(): + self.read_file(LstripReader(str(self.conf_file)), source=conffile) + self.includelist = includelist + self.excludelist = excludelist + self.isdirty = False + + def reload(self): + self.clear() + if self.conf_file.exists(): + self.read_file(LstripReader(str(self.conf_file)), source=self.conf_file) + + + def set(self, name, option, value): + """ + Sets a configuration value for a specific submodule: + Ensures the appropriate section exists for the submodule. + Calls the parent class's set method to store the value. + """ + self.isdirty = True + self.logger.debug("set called {} {} {}".format(name, option, value)) + section = f'submodule "{name}"' + if not self.has_section(section): + self.add_section(section) + super().set(section, option, str(value)) + + # pylint: disable=redefined-builtin, arguments-differ + def get(self, name, option, raw=False, vars=None, fallback=None): + """ + Retrieves a configuration value for a specific submodule: + Uses the parent class's get method to access the value. + Handles potential errors if the section or option doesn't exist. + """ + self.logger.debug("git get called {} {}".format(name, option)) + section = f'submodule "{name}"' + try: + return ConfigParser.get( + self, section, option, raw=raw, vars=vars, fallback=fallback + ) + except ConfigParser.NoOptionError: + return None + + def save(self): + if self.isdirty: + self.logger.info("Writing {}".format(self.conf_file)) + with open(self.conf_file, "w") as fd: + self.write(fd) + self.isdirty = False + + def __del__(self): + self.save() + + def sections(self): + """Strip the submodule part out of section and just use the name""" + self.logger.debug("calling GitModules sections iterator") + names = [] + for section in ConfigParser.sections(self): + name = section[11:-1] + if self.includelist and name not in self.includelist: + continue + if self.excludelist and name in self.excludelist: + continue + names.append(name) + return names + + def items(self, name, raw=False, vars=None): + self.logger.debug("calling GitModules items for {}".format(name)) + section = f'submodule "{name}"' + return ConfigParser.items(section, raw=raw, vars=vars) diff --git a/.lib/git_fleximod/lstripreader.py b/.lib/git_fleximod/lstripreader.py new file mode 100644 index 0000000000..01d5580ee8 --- /dev/null +++ b/.lib/git_fleximod/lstripreader.py @@ -0,0 +1,43 @@ +class LstripReader(object): + "LstripReader formats .gitmodules files to be acceptable for configparser" + + def __init__(self, filename): + with open(filename, "r") as infile: + lines = infile.readlines() + self._lines = list() + self._num_lines = len(lines) + self._index = 0 + for line in lines: + self._lines.append(line.lstrip()) + + def readlines(self): + """Return all the lines from this object's file""" + return self._lines + + def readline(self, size=-1): + """Format and return the next line or raise StopIteration""" + try: + line = self.next() + except StopIteration: + line = "" + + if (size > 0) and (len(line) < size): + return line[0:size] + + return line + + def __iter__(self): + """Begin an iteration""" + self._index = 0 + return self + + def next(self): + """Return the next line or raise StopIteration""" + if self._index >= self._num_lines: + raise StopIteration + + self._index = self._index + 1 + return self._lines[self._index - 1] + + def __next__(self): + return self.next() diff --git a/.lib/git_fleximod/metoflexi.py b/.lib/git_fleximod/metoflexi.py new file mode 100755 index 0000000000..cc347db2dd --- /dev/null +++ b/.lib/git_fleximod/metoflexi.py @@ -0,0 +1,236 @@ +#!/usr/bin/env python +from configparser import ConfigParser +import sys +import shutil +from pathlib import Path +import argparse +import logging +from git_fleximod.gitinterface import GitInterface +from git_fleximod.gitmodules import GitModules +from git_fleximod import utils + +logger = None + +def find_root_dir(filename=".git"): + d = Path.cwd() + root = Path(d.root) + while d != root: + attempt = d / filename + if attempt.is_dir(): + return d + d = d.parent + return None + + +def get_parser(): + description = """ + %(prog)s manages checking out groups of gitsubmodules with addtional support for Earth System Models + """ + parser = argparse.ArgumentParser( + description=description, formatter_class=argparse.RawDescriptionHelpFormatter + ) + + parser.add_argument('-e', '--externals', nargs='?', + default='Externals.cfg', + help='The externals description filename. ' + 'Default: %(default)s.') + + parser.add_argument( + "-C", + "--path", + default=find_root_dir(), + help="Toplevel repository directory. Defaults to top git directory relative to current.", + ) + + parser.add_argument( + "-g", + "--gitmodules", + nargs="?", + default=".gitmodules", + help="The submodule description filename. " "Default: %(default)s.", + ) + parser.add_argument( + "-v", + "--verbose", + action="count", + default=0, + help="Output additional information to " + "the screen and log file. This flag can be " + "used up to two times, increasing the " + "verbosity level each time.", + ) + parser.add_argument( + "-d", + "--debug", + action="store_true", + default=False, + help="DEVELOPER: output additional debugging " + "information to the screen and log file.", + ) + + return parser + +def commandline_arguments(args=None): + parser = get_parser() + + options = parser.parse_args(args) + handlers = [logging.StreamHandler()] + + if options.debug: + try: + open("fleximod.log", "w") + except PermissionError: + sys.exit("ABORT: Could not write file fleximod.log") + level = logging.DEBUG + handlers.append(logging.FileHandler("fleximod.log")) + elif options.verbose: + level = logging.INFO + else: + level = logging.WARNING + # Configure the root logger + logging.basicConfig( + level=level, format="%(name)s - %(levelname)s - %(message)s", handlers=handlers + ) + + return( + options.path, + options.gitmodules, + options.externals + ) + +class ExternalRepoTranslator: + """ + Translates external repositories configured in an INI-style externals file. + """ + + def __init__(self, rootpath, gitmodules, externals): + self.rootpath = rootpath + if gitmodules: + self.gitmodules = GitModules(logger, confpath=rootpath) + self.externals = (rootpath / Path(externals)).resolve() + print(f"Translating {self.externals}") + self.git = GitInterface(rootpath, logger) + +# def __del__(self): +# if (self.rootpath / "save.gitignore"): + + + def translate_single_repo(self, section, tag, url, path, efile, hash_, sparse, protocol): + """ + Translates a single repository based on configuration details. + + Args: + rootpath (str): Root path of the main repository. + gitmodules (str): Path to the .gitmodules file. + tag (str): The tag to use for the external repository. + url (str): The URL of the external repository. + path (str): The relative path within the main repository for the external repository. + efile (str): The external file or file containing submodules. + hash_ (str): The commit hash to checkout (if applicable). + sparse (str): Boolean indicating whether to use sparse checkout (if applicable). + protocol (str): The protocol to use (e.g., 'git', 'http'). + """ + assert protocol != "svn", "SVN protocol is not currently supported" + print(f"Translating repository {section}") + if efile: + file_path = Path(path) / Path(efile) + newroot = (self.rootpath / file_path).parent.resolve() + if not newroot.exists(): + newroot.mkdir(parents=True) + logger.info("Newroot is {}".format(newroot)) + newt = ExternalRepoTranslator(newroot, ".gitmodules", efile) + newt.translate_repo() + if protocol == "externals_only": + if tag: + self.gitmodules.set(section, "fxtag", tag) + if hash_: + self.gitmodules.set(section, "fxtag", hash_) + + self.gitmodules.set(section, "fxDONOTUSEurl", url) + if sparse: + self.gitmodules.set(section, "fxsparse", sparse) + self.gitmodules.set(section, "fxrequired", "ToplevelRequired") + else: + newpath = (self.rootpath / Path(path)) + if newpath.exists(): + shutil.rmtree(newpath) + logger.info("Creating directory {}".format(newpath)) + newpath.mkdir(parents=True) + if tag: + logger.info("cloning {}".format(section)) + try: + self.git.git_operation("clone", "-b", tag, "--depth", "1", url, path) + except: + self.git.git_operation("clone", url, path) + with utils.pushd(newpath): + ngit = GitInterface(newpath, logger) + ngit.git_operation("checkout", tag) + if hash_: + self.git.git_operation("clone", url, path) + git = GitInterface(newpath, logger) + git.git_operation("fetch", "origin") + git.git_operation("checkout", hash_) + if sparse: + print("setting as sparse submodule {}".format(section)) + sparsefile = (newpath / Path(sparse)) + newfile = (newpath / ".git" / "info" / "sparse-checkout") + print(f"sparsefile {sparsefile} newfile {newfile}") + shutil.copy(sparsefile, newfile) + + logger.info("adding submodule {}".format(section)) + self.gitmodules.save() + self.git.git_operation("submodule", "add", "-f", "--name", section, url, path) + self.git.git_operation("submodule","absorbgitdirs") + self.gitmodules.reload() + if tag: + self.gitmodules.set(section, "fxtag", tag) + if hash_: + self.gitmodules.set(section, "fxtag", hash_) + + self.gitmodules.set(section, "fxDONOTUSEurl", url) + if sparse: + self.gitmodules.set(section, "fxsparse", sparse) + self.gitmodules.set(section, "fxrequired", "ToplevelRequired") + + + def translate_repo(self): + """ + Translates external repositories defined within an external file. + + Args: + rootpath (str): Root path of the main repository. + gitmodules (str): Path to the .gitmodules file. + external_file (str): The path to the external file containing repository definitions. + """ + econfig = ConfigParser() + econfig.read((self.rootpath / Path(self.externals))) + + for section in econfig.sections(): + if section == "externals_description": + logger.info("skipping section {}".format(section)) + return + logger.info("Translating section {}".format(section)) + tag = econfig.get(section, "tag", raw=False, fallback=None) + url = econfig.get(section, "repo_url", raw=False, fallback=None) + path = econfig.get(section, "local_path", raw=False, fallback=None) + efile = econfig.get(section, "externals", raw=False, fallback=None) + hash_ = econfig.get(section, "hash", raw=False, fallback=None) + sparse = econfig.get(section, "sparse", raw=False, fallback=None) + protocol = econfig.get(section, "protocol", raw=False, fallback=None) + + self.translate_single_repo(section, tag, url, path, efile, hash_, sparse, protocol) + + + +def _main(): + rootpath, gitmodules, externals = commandline_arguments() + global logger + logger = logging.getLogger(__name__) + with utils.pushd(rootpath): + t = ExternalRepoTranslator(Path(rootpath), gitmodules, externals) + logger.info("Translating {}".format(rootpath)) + t.translate_repo() + + +if __name__ == "__main__": + sys.exit(_main()) diff --git a/.lib/git_fleximod/submodule.py b/.lib/git_fleximod/submodule.py new file mode 100644 index 0000000000..48c59a064a --- /dev/null +++ b/.lib/git_fleximod/submodule.py @@ -0,0 +1,455 @@ +import os +import textwrap +import shutil +import string +from configparser import NoOptionError +from git_fleximod import utils +from git_fleximod.gitinterface import GitInterface + +class Submodule(): + """ + Represents a Git submodule with enhanced features for flexible management. + + Attributes: + name (str): The name of the submodule. + root_dir (str): The root directory of the main project. + path (str): The relative path from the root directory to the submodule. + url (str): The URL of the submodule repository. + fxurl (str): The URL for flexible submodule management (optional). + fxtag (str): The tag for flexible submodule management (optional). + fxsparse (str): Path to the sparse checkout file relative to the submodule path, see git-sparse-checkout for details (optional). + fxrequired (str): Indicates if the submodule is optional or required (optional). + logger (logging.Logger): Logger instance for logging (optional). + """ + def __init__(self, root_dir, name, path, url, fxtag=None, fxurl=None, fxsparse=None, fxrequired=None, logger=None): + """ + Initializes a new Submodule instance with the provided attributes. + """ + self.name = name + self.root_dir = root_dir + self.path = path + self.url = url + self.fxurl = fxurl + self.fxtag = fxtag + self.fxsparse = fxsparse + if fxrequired: + self.fxrequired = fxrequired + else: + self.fxrequired = "AlwaysRequired" + self.logger = logger + + def status(self): + """ + Checks the status of the submodule and returns 4 parameters: + - result (str): The status of the submodule. + - needsupdate (bool): An indicator if the submodule needs to be updated. + - localmods (bool): An indicator if the submodule has local modifications. + - testfails (bool): An indicator if the submodule has failed a test, this is used for testing purposes. + """ + + smpath = os.path.join(self.root_dir, self.path) + testfails = False + localmods = False + needsupdate = False + ahash = None + optional = "" + if "Optional" in self.fxrequired: + optional = " (optional)" + required = None + level = None + if not os.path.exists(os.path.join(smpath, ".git")): + rootgit = GitInterface(self.root_dir, self.logger) + # submodule commands use path, not name + status, tags = rootgit.git_operation("ls-remote", "--tags", self.url) + status, result = rootgit.git_operation("submodule","status",smpath) + result = result.split() + + if result: + ahash = result[0][1:] + hhash = None + atag = None + for htag in tags.split("\n"): + if htag.endswith('^{}'): + htag = htag[:-3] + if ahash and not atag and ahash in htag: + atag = (htag.split()[1])[10:] + if self.fxtag and not hhash and htag.endswith(self.fxtag): + hhash = htag.split()[0] + if hhash and atag: + break + if self.fxtag and (ahash == hhash or atag == self.fxtag): + result = f"e {self.name:>20} not checked out, aligned at tag {self.fxtag}{optional}" + needsupdate = True + elif self.fxtag: + status, ahash = rootgit.git_operation( + "submodule", "status", "{}".format(self.path) + ) + ahash = ahash[1 : len(self.fxtag) + 1] + if self.fxtag == ahash: + result = f"e {self.name:>20} not checked out, aligned at hash {ahash}{optional}" + else: + result = f"e {self.name:>20} not checked out, out of sync at tag {atag}, expected tag is {self.fxtag}{optional}" + testfails = True + needsupdate = True + else: + result = f"e {self.name:>20} has no fxtag defined in .gitmodules{optional}" + testfails = False + else: + with utils.pushd(smpath): + git = GitInterface(smpath, self.logger) + status, remote = git.git_operation("remote") + if remote == '': + result = f"e {self.name:>20} has no associated remote" + testfails = True + needsupdate = True + return result, needsupdate, localmods, testfails + status, rurl = git.git_operation("ls-remote","--get-url") + status, lines = git.git_operation("log", "--pretty=format:\"%h %d\"") + line = lines.partition('\n')[0] + parts = line.split() + ahash = parts[0][1:] + atag = None + if len(parts) > 3: + idx = 0 + while idx < len(parts)-1: + idx = idx+1 + if parts[idx] == 'tag:': + atag = parts[idx+1] + while atag.endswith(')') or atag.endswith(',') or atag.endswith("\""): + atag = atag[:-1] + if atag == self.fxtag: + break + + + #print(f"line is {line} ahash is {ahash} atag is {atag} {parts}") + # atag = git.git_operation("describe", "--tags", "--always") + # ahash = git.git_operation("rev-list", "HEAD").partition("\n")[0] + + recurse = False + if rurl != self.url: + remote = self._add_remote(git) + git.git_operation("fetch", remote) + if self.fxtag and atag == self.fxtag: + result = f" {self.name:>20} at tag {self.fxtag}" + recurse = True + testfails = False + elif self.fxtag and (ahash[: len(self.fxtag)] == self.fxtag or (self.fxtag.find(ahash)==0)): + result = f" {self.name:>20} at hash {ahash}" + recurse = True + testfails = False + elif atag == ahash: + result = f" {self.name:>20} at hash {ahash}" + recurse = True + elif self.fxtag: + result = f"s {self.name:>20} {atag} {ahash} is out of sync with .gitmodules {self.fxtag}" + testfails = True + needsupdate = True + else: + if atag: + result = f"e {self.name:>20} has no fxtag defined in .gitmodules, module at {atag}" + else: + result = f"e {self.name:>20} has no fxtag defined in .gitmodules, module at {ahash}" + testfails = False + + status, output = git.git_operation("status", "--ignore-submodules", "-uno") + if "nothing to commit" not in output: + localmods = True + result = "M" + textwrap.indent(output, " ") +# print(f"result {result} needsupdate {needsupdate} localmods {localmods} testfails {testfails}") + return result, needsupdate, localmods, testfails + + + def _add_remote(self, git): + """ + Adds a new remote to the submodule if it does not already exist. + + This method checks the existing remotes of the submodule. If the submodule's URL is not already listed as a remote, + it attempts to add a new remote. The name for the new remote is generated dynamically to avoid conflicts. If no + remotes exist, it defaults to naming the new remote 'origin'. + + Args: + git (GitInterface): An instance of GitInterface to perform git operations. + + Returns: + str: The name of the new remote if added, or the name of the existing remote that matches the submodule's URL. + """ + status, remotes = git.git_operation("remote", "-v") + remotes = remotes.splitlines() + upstream = None + if remotes: + status, upstream = git.git_operation("ls-remote", "--get-url") + newremote = "newremote.00" + tmpurl = self.url.replace("git@github.com:", "https://github.com/") + line = next((s for s in remotes if self.url in s or tmpurl in s), None) + if line: + newremote = line.split()[0] + return newremote + else: + i = 0 + while newremote in remotes: + i = i + 1 + newremote = f"newremote.{i:02d}" + else: + newremote = "origin" + git.git_operation("remote", "add", newremote, self.url) + return newremote + + def toplevel(self): + """ + Returns True if the submodule is Toplevel (either Required or Optional) + """ + return True if "Top" in self.fxrequired else False + + def sparse_checkout(self): + """ + Performs a sparse checkout of the submodule. + + This method optimizes the checkout process by only checking out files specified in the submodule's sparse-checkout configuration, + rather than the entire submodule content. It achieves this by first ensuring the `.git/info/sparse-checkout` file is created and + configured in the submodule's directory. Then, it proceeds to checkout the desired tag. If the submodule has already been checked out, + this method will not perform the checkout again. + + This approach is particularly beneficial for submodules with a large number of files, as it significantly reduces the time and disk space + required for the checkout process by avoiding the unnecessary checkout and subsequent removal of unneeded files. + + Returns: + None + """ + self.logger.info("Called sparse_checkout for {}".format(self.name)) + rgit = GitInterface(self.root_dir, self.logger) + status, superroot = rgit.git_operation("rev-parse", "--show-superproject-working-tree") + if superroot: + gitroot = superroot.strip() + else: + gitroot = self.root_dir + # Now need to move the .git dir to the submodule location + rootdotgit = os.path.join(self.root_dir, ".git") + while os.path.isfile(rootdotgit): + with open(rootdotgit) as f: + line = f.readline().rstrip() + if line.startswith("gitdir: "): + rootdotgit = os.path.abspath(os.path.join(self.root_dir,line[8:])) + assert os.path.isdir(rootdotgit) + # first create the module directory + if not os.path.isdir(os.path.join(self.root_dir, self.path)): + os.makedirs(os.path.join(self.root_dir, self.path)) + + # initialize a new git repo and set the sparse checkout flag + sprep_repo = os.path.join(self.root_dir, self.path) + sprepo_git = GitInterface(sprep_repo, self.logger) + if os.path.exists(os.path.join(sprep_repo, ".git")): + try: + self.logger.info("Submodule {} found".format(self.name)) + chk = sprepo_git.config_get_value("core", "sparseCheckout") + if chk == "true": + self.logger.info("Sparse submodule {} already checked out".format(self.name)) + return + except (NoOptionError): + self.logger.debug("Sparse submodule {} not present".format(self.name)) + except Exception as e: + utils.fatal_error("Unexpected error {} occured.".format(e)) + + sprepo_git.config_set_value("core", "sparseCheckout", "true") + + # set the repository remote + + self.logger.info("Setting remote origin in {}/{}".format(self.root_dir, self.path)) + status, remotes = sprepo_git.git_operation("remote", "-v") + if self.url not in remotes: + sprepo_git.git_operation("remote", "add", "origin", self.url) + + topgit = os.path.join(gitroot, ".git") + + if gitroot != self.root_dir and os.path.isfile(os.path.join(self.root_dir, ".git")): + with open(os.path.join(self.root_dir, ".git")) as f: + gitpath = os.path.relpath( + os.path.join(self.root_dir, f.read().split()[1]), + start=os.path.join(self.root_dir, self.path), + ) + rootdotgit = os.path.join(gitpath, "modules", self.name) + else: + rootdotgit = os.path.relpath( + os.path.join(self.root_dir, ".git", "modules", self.name), + start=os.path.join(self.root_dir, self.path), + ) + + if os.path.isdir(os.path.join(self.root_dir, self.path, ".git")): + with utils.pushd(sprep_repo): + if os.path.isdir(os.path.join(rootdotgit,".git")): + shutil.rmtree(os.path.join(rootdotgit,".git")) + shutil.move(".git", rootdotgit) + with open(".git", "w") as f: + f.write("gitdir: " + os.path.relpath(rootdotgit)) + infodir = os.path.join(rootdotgit, "info") + if not os.path.isdir(infodir): + os.makedirs(infodir) + gitsparse = os.path.abspath(os.path.join(infodir, "sparse-checkout")) + if os.path.isfile(gitsparse): + self.logger.warning( + "submodule {} is already initialized {}".format(self.name, rootdotgit) + ) + os.remove(gitsparse) + + if os.path.isfile(self.fxsparse): + shutil.copy(self.fxsparse, gitsparse) + else: + self.logger.warning( + "submodule {} could not find {}".format(self.name, self.fxsparse) + ) + + # Finally checkout the repo + sprepo_git.git_operation("fetch", "origin", "--tags") + status,_ = sprepo_git.git_operation("checkout", self.fxtag) + if status: + print(f"Error checking out {self.name:>20} at {self.fxtag}") + else: + print(f"Successfully checked out {self.name:>20} at {self.fxtag}") + status,f = sprepo_git.git_operation("status") + # Restore any files deleted from sandbox + for line in f.splitlines(): + if "deleted:" in line: + deleted_file = line.split("deleted:")[1].strip() + sprepo_git.git_operation("checkout", deleted_file) + + rgit.config_set_value('submodule.' + self.name, "active", "true") + rgit.config_set_value('submodule.' + self.name, "url", self.url) + rgit.config_set_value('submodule.' + self.name, "path", self.path) + + async def update(self): + """ + Updates the submodule to the latest or specified version. + + This method handles the update process of the submodule, including checking out the submodule into the specified path, + handling sparse checkouts if configured, and updating the submodule's URL if necessary. It supports both SSH and HTTPS URLs, + automatically converting SSH URLs to HTTPS to avoid issues for users without SSH keys. + + The update process involves the following steps: + 1. If the submodule is configured for sparse checkout, it performs a sparse checkout. + 2. If the submodule is not already checked out, it clones the submodule using the provided URL. + 3. If a specific tag or hash is provided, it checks out that tag; otherwise, it checks out the latest version. + 4. If the root `.git` is a file (indicating a submodule or a worktree), additional steps are taken to integrate the submodule properly. + + Args: + None + Note: + - SSH URLs are automatically converted to HTTPS to accommodate users without SSH keys. + + Returns: + None + """ + git = GitInterface(self.root_dir, self.logger) + repodir = os.path.join(self.root_dir, self.path) + self.logger.info("Checkout {} into {}/{}".format(self.name, self.root_dir, self.path)) + # if url is provided update to the new url + tag = None + repo_exists = False + if os.path.exists(os.path.join(repodir, ".git")): + self.logger.info("Submodule {} already checked out".format(self.name)) + repo_exists = True + # Look for a .gitmodules file in the newly checkedout repo + if self.fxsparse: + print(f"Sparse checkout {self.name} fxsparse {self.fxsparse}") + if not os.path.isfile(self.fxsparse): + self.logger.info("Submodule {} fxsparse file not found".format(self.name)) + + self.sparse_checkout() + else: + if not repo_exists and self.url: + # ssh urls cause problems for those who dont have git accounts with ssh keys defined + # but cime has one since e3sm prefers ssh to https, because the .gitmodules file was + # opened with a GitModules object we don't need to worry about restoring the file here + # it will be done by the GitModules class + if self.url.startswith("git@"): + git.git_operation("clone", self.url, self.path) + smgit = GitInterface(repodir, self.logger) + if not tag: + status, tag = smgit.git_operation("describe", "--tags", "--always") + smgit.git_operation("checkout", tag) + # Now need to move the .git dir to the submodule location + rootdotgit = os.path.join(self.root_dir, ".git") + if os.path.isfile(rootdotgit): + with open(rootdotgit) as f: + line = f.readline() + if line.startswith("gitdir: "): + rootdotgit = line[8:] + + newpath = os.path.abspath(os.path.join(self.root_dir, rootdotgit, "modules", self.name)) + if os.path.exists(newpath): + shutil.rmtree(os.path.join(repodir, ".git")) + else: + shutil.move(os.path.join(repodir, ".git"), newpath) + + with open(os.path.join(repodir, ".git"), "w") as f: + f.write("gitdir: " + os.path.relpath(newpath, start=repodir)) + + if not os.path.exists(repodir): + parent = os.path.dirname(repodir) + if not os.path.isdir(parent): + os.makedirs(parent) + git.git_operation("submodule", "add", "--name", self.name, "--", self.url, self.path) + + if not repo_exists: + git.git_operation("submodule", "init", "--", self.path) + await git.git_operation_async("submodule", "update", "--", self.path) + + if self.fxtag: + smgit = GitInterface(repodir, self.logger) + newremote = self._add_remote(smgit) + # Trying to distingush a tag from a hash + allowed = set(string.digits + 'abcdef') + if not set(self.fxtag) <= allowed: + # This is a tag + tag = f"refs/tags/{self.fxtag}:refs/tags/{self.fxtag}" + smgit.git_operation("fetch", newremote, tag) + smgit.git_operation("checkout", self.fxtag) + + if not os.path.exists(os.path.join(repodir, ".git")): + utils.fatal_error( + f"Failed to checkout {self.name} {repo_exists} {repodir} {self.path}" + ) + + + if os.path.exists(os.path.join(self.path, ".git")): + submoddir = os.path.join(self.root_dir, self.path) + with utils.pushd(submoddir): + git = GitInterface(submoddir, self.logger) + # first make sure the url is correct + newremote = self._add_remote(git) + status, tags = git.git_operation("tag", "-l") + fxtag = self.fxtag + if fxtag and fxtag not in tags: + git.git_operation("fetch", newremote, "--tags") + status, atag = git.git_operation("describe", "--tags", "--always") + status, files = git.git_operation("diff", "--name-only", "-z") + modfiles = [] + moddirs = [] + if files: + for f in files.split('\0'): + if f: + if os.path.exists(f): + git.git_operation("checkout",f) + elif os.path.isdir(f): + moddirs.append(f) + else: + modfiles.append(f) + if fxtag and fxtag != atag: + try: + status, _ = git.git_operation("checkout", fxtag) + if not status: + print(f"{self.name:>20} updated to {fxtag}") + except Exception as error: + print(error) + + + elif not fxtag: + print(f"No fxtag found for submodule {self.name:>20}") + elif modfiles: + print(f"{self.name:>20} has modified files: {modfiles}") + elif moddirs: + print(f"{self.name:>20} has modified directories: {moddirs}") + else: + print(f"{self.name:>20} up to date.") + + + + return diff --git a/.lib/git_fleximod/utils.py b/.lib/git_fleximod/utils.py new file mode 100644 index 0000000000..c4f43d5238 --- /dev/null +++ b/.lib/git_fleximod/utils.py @@ -0,0 +1,365 @@ +#!/usr/bin/env python3 +""" +Common public utilities for manic package + +""" + +import logging +import os +import subprocess +import sys +from threading import Timer +from pathlib import Path + +LOCAL_PATH_INDICATOR = "." +# --------------------------------------------------------------------- +# +# functions to massage text for output and other useful utilities +# +# --------------------------------------------------------------------- +from contextlib import contextmanager + + +@contextmanager +def pushd(new_dir): + """context for chdir. usage: with pushd(new_dir)""" + previous_dir = os.getcwd() + os.chdir(new_dir) + try: + yield + finally: + os.chdir(previous_dir) + + +def log_process_output(output): + """Log each line of process output at debug level so it can be + filtered if necessary. By default, output is a single string, and + logging.debug(output) will only put log info heading on the first + line. This makes it hard to filter with grep. + + """ + output = output.split("\n") + for line in output: + logging.debug(line) + + +def printlog(msg, **kwargs): + """Wrapper script around print to ensure that everything printed to + the screen also gets logged. + + """ + logging.info(msg) + if kwargs: + print(msg, **kwargs) + else: + print(msg) + sys.stdout.flush() + + +def find_upwards(root_dir, filename): + """Find a file in root dir or any of it's parents""" + d = Path(root_dir) + root = Path(d.root) + while d != root: + attempt = d / filename + if attempt.exists(): + return attempt + d = d.parent + return None + + +def last_n_lines(the_string, n_lines, truncation_message=None): + """Returns the last n lines of the given string + + Args: + the_string: str + n_lines: int + truncation_message: str, optional + + Returns a string containing the last n lines of the_string + + If truncation_message is provided, the returned string begins with + the given message if and only if the string is greater than n lines + to begin with. + """ + + lines = the_string.splitlines(True) + if len(lines) <= n_lines: + return_val = the_string + else: + lines_subset = lines[-n_lines:] + str_truncated = "".join(lines_subset) + if truncation_message: + str_truncated = truncation_message + "\n" + str_truncated + return_val = str_truncated + + return return_val + + +def indent_string(the_string, indent_level): + """Indents the given string by a given number of spaces + + Args: + the_string: str + indent_level: int + + Returns a new string that is the same as the_string, except that + each line is indented by 'indent_level' spaces. + + In python3, this can be done with textwrap.indent. + """ + + lines = the_string.splitlines(True) + padding = " " * indent_level + lines_indented = [padding + line for line in lines] + return "".join(lines_indented) + + +# --------------------------------------------------------------------- +# +# error handling +# +# --------------------------------------------------------------------- + + +def fatal_error(message): + """ + Error output function + """ + logging.error(message) + raise RuntimeError("{0}ERROR: {1}".format(os.linesep, message)) + + +# --------------------------------------------------------------------- +# +# Data conversion / manipulation +# +# --------------------------------------------------------------------- +def str_to_bool(bool_str): + """Convert a sting representation of as boolean into a true boolean. + + Conversion should be case insensitive. + """ + value = None + str_lower = bool_str.lower() + if str_lower in ("true", "t"): + value = True + elif str_lower in ("false", "f"): + value = False + if value is None: + msg = ( + 'ERROR: invalid boolean string value "{0}". ' + 'Must be "true" or "false"'.format(bool_str) + ) + fatal_error(msg) + return value + + +REMOTE_PREFIXES = ["http://", "https://", "ssh://", "git@"] + + +def is_remote_url(url): + """check if the user provided a local file path instead of a + remote. If so, it must be expanded to an absolute + path. + + """ + remote_url = False + for prefix in REMOTE_PREFIXES: + if url.startswith(prefix): + remote_url = True + return remote_url + + +def split_remote_url(url): + """check if the user provided a local file path or a + remote. If remote, try to strip off protocol info. + + """ + remote_url = is_remote_url(url) + if not remote_url: + return url + + for prefix in REMOTE_PREFIXES: + url = url.replace(prefix, "") + + if "@" in url: + url = url.split("@")[1] + + if ":" in url: + url = url.split(":")[1] + + return url + + +def expand_local_url(url, field): + """check if the user provided a local file path instead of a + remote. If so, it must be expanded to an absolute + path. + + Note: local paths of LOCAL_PATH_INDICATOR have special meaning and + represent local copy only, don't work with the remotes. + + """ + remote_url = is_remote_url(url) + if not remote_url: + if url.strip() == LOCAL_PATH_INDICATOR: + pass + else: + url = os.path.expandvars(url) + url = os.path.expanduser(url) + if not os.path.isabs(url): + msg = ( + 'WARNING: Externals description for "{0}" contains a ' + "url that is not remote and does not expand to an " + "absolute path. Version control operations may " + "fail.\n\nurl={1}".format(field, url) + ) + printlog(msg) + else: + url = os.path.normpath(url) + return url + + +# --------------------------------------------------------------------- +# +# subprocess +# +# --------------------------------------------------------------------- + +# Give the user a helpful message if we detect that a command seems to +# be hanging. +_HANGING_SEC = 300 + + +def _hanging_msg(working_directory, command): + print( + """ + +Command '{command}' +from directory {working_directory} +has taken {hanging_sec} seconds. It may be hanging. + +The command will continue to run, but you may want to abort +git-fleximod with ^C and investigate. A possible cause of hangs is git +requires authentication to access a private repository. On some +systems, git requests for authentication information will not +be displayed to the user. In this case, the program will appear to +hang. Ensure you can run git manually and access all +repositories without entering your authentication information. + +""".format( + command=command, + working_directory=working_directory, + hanging_sec=_HANGING_SEC, + ) + ) + + +def execute_subprocess(commands, status_to_caller=False, output_to_caller=False): + """Wrapper around subprocess.check_output to handle common + exceptions. + + check_output runs a command with arguments and waits + for it to complete. + + check_output raises an exception on a nonzero return code. if + status_to_caller is true, execute_subprocess returns the subprocess + return code, otherwise execute_subprocess treats non-zero return + status as an error and raises an exception. + + """ + cwd = os.getcwd() + msg = "In directory: {0}\nexecute_subprocess running command:".format(cwd) + logging.info(msg) + commands_str = " ".join(str(element) for element in commands) + logging.info(commands_str) + return_to_caller = status_to_caller or output_to_caller + status = -1 + output = "" + hanging_timer = Timer( + _HANGING_SEC, + _hanging_msg, + kwargs={"working_directory": cwd, "command": commands_str}, + ) + hanging_timer.start() + try: + output = subprocess.check_output( + commands, stderr=subprocess.STDOUT, universal_newlines=True + ) + log_process_output(output) + status = 0 + except OSError as error: + msg = failed_command_msg( + "Command execution failed. Does the executable exist?", commands + ) + logging.error(error) + fatal_error(msg) + except ValueError as error: + msg = failed_command_msg( + "DEV_ERROR: Invalid arguments trying to run subprocess", commands + ) + logging.error(error) + fatal_error(msg) + except subprocess.CalledProcessError as error: + # Only report the error if we are NOT returning to the + # caller. If we are returning to the caller, then it may be a + # simple status check. If returning, it is the callers + # responsibility determine if an error occurred and handle it + # appropriately. + msg_context = ( + "Process did not run successfully; " + "returned status {0}".format(error.returncode) + ) + msg = failed_command_msg(msg_context, commands, output=error.output) + if not return_to_caller: + logging.error(error) + logging.error(msg) + log_process_output(error.output) + fatal_error(msg) + status = error.returncode + finally: + hanging_timer.cancel() + + if status_to_caller and output_to_caller: + ret_value = (status, output) + elif status_to_caller: + ret_value = status + elif output_to_caller: + ret_value = output + else: + ret_value = None + + return ret_value + + +def failed_command_msg(msg_context, command, output=None): + """Template for consistent error messages from subprocess calls. + + If 'output' is given, it should provide the output from the failed + command + """ + + if output: + output_truncated = last_n_lines( + output, 20, truncation_message="[... Output truncated for brevity ...]" + ) + errmsg = ( + "Failed with output:\n" + indent_string(output_truncated, 4) + "\nERROR: " + ) + else: + errmsg = "" + + command_str = " ".join(command) + errmsg += """In directory + {cwd} +{context}: + {command} +""".format( + cwd=os.getcwd(), context=msg_context, command=command_str + ) + + if output: + errmsg += "See above for output from failed command.\n" + + return errmsg diff --git a/.lib/poetry.lock b/.lib/poetry.lock new file mode 100644 index 0000000000..ac82fb0d97 --- /dev/null +++ b/.lib/poetry.lock @@ -0,0 +1,693 @@ +# This file is automatically @generated by Poetry 1.7.1 and should not be changed by hand. + +[[package]] +name = "alabaster" +version = "0.7.13" +description = "A configurable sidebar-enabled Sphinx theme" +optional = false +python-versions = ">=3.6" +files = [ + {file = "alabaster-0.7.13-py3-none-any.whl", hash = "sha256:1ee19aca801bbabb5ba3f5f258e4422dfa86f82f3e9cefb0859b283cdd7f62a3"}, + {file = "alabaster-0.7.13.tar.gz", hash = "sha256:a27a4a084d5e690e16e01e03ad2b2e552c61a65469419b907243193de1a84ae2"}, +] + +[[package]] +name = "babel" +version = "2.15.0" +description = "Internationalization utilities" +optional = false +python-versions = ">=3.8" +files = [ + {file = "Babel-2.15.0-py3-none-any.whl", hash = "sha256:08706bdad8d0a3413266ab61bd6c34d0c28d6e1e7badf40a2cebe67644e2e1fb"}, + {file = "babel-2.15.0.tar.gz", hash = "sha256:8daf0e265d05768bc6c7a314cf1321e9a123afc328cc635c18622a2f30a04413"}, +] + +[package.dependencies] +pytz = {version = ">=2015.7", markers = "python_version < \"3.9\""} + +[package.extras] +dev = ["freezegun (>=1.0,<2.0)", "pytest (>=6.0)", "pytest-cov"] + +[[package]] +name = "certifi" +version = "2024.8.30" +description = "Python package for providing Mozilla's CA Bundle." +optional = false +python-versions = ">=3.6" +files = [ + {file = "certifi-2024.8.30-py3-none-any.whl", hash = "sha256:922820b53db7a7257ffbda3f597266d435245903d80737e34f8a45ff3e3230d8"}, + {file = "certifi-2024.8.30.tar.gz", hash = "sha256:bec941d2aa8195e248a60b31ff9f0558284cf01a52591ceda73ea9afffd69fd9"}, +] + +[[package]] +name = "charset-normalizer" +version = "3.3.2" +description = "The Real First Universal Charset Detector. Open, modern and actively maintained alternative to Chardet." +optional = false +python-versions = ">=3.7.0" +files = [ + {file = "charset-normalizer-3.3.2.tar.gz", hash = "sha256:f30c3cb33b24454a82faecaf01b19c18562b1e89558fb6c56de4d9118a032fd5"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-macosx_10_9_universal2.whl", hash = "sha256:25baf083bf6f6b341f4121c2f3c548875ee6f5339300e08be3f2b2ba1721cdd3"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-macosx_10_9_x86_64.whl", hash = "sha256:06435b539f889b1f6f4ac1758871aae42dc3a8c0e24ac9e60c2384973ad73027"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-macosx_11_0_arm64.whl", hash = "sha256:9063e24fdb1e498ab71cb7419e24622516c4a04476b17a2dab57e8baa30d6e03"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:6897af51655e3691ff853668779c7bad41579facacf5fd7253b0133308cf000d"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-manylinux_2_17_ppc64le.manylinux2014_ppc64le.whl", hash = "sha256:1d3193f4a680c64b4b6a9115943538edb896edc190f0b222e73761716519268e"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-manylinux_2_17_s390x.manylinux2014_s390x.whl", hash = "sha256:cd70574b12bb8a4d2aaa0094515df2463cb429d8536cfb6c7ce983246983e5a6"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:8465322196c8b4d7ab6d1e049e4c5cb460d0394da4a27d23cc242fbf0034b6b5"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:a9a8e9031d613fd2009c182b69c7b2c1ef8239a0efb1df3f7c8da66d5dd3d537"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-musllinux_1_1_aarch64.whl", hash = "sha256:beb58fe5cdb101e3a055192ac291b7a21e3b7ef4f67fa1d74e331a7f2124341c"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-musllinux_1_1_i686.whl", hash = "sha256:e06ed3eb3218bc64786f7db41917d4e686cc4856944f53d5bdf83a6884432e12"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-musllinux_1_1_ppc64le.whl", hash = "sha256:2e81c7b9c8979ce92ed306c249d46894776a909505d8f5a4ba55b14206e3222f"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-musllinux_1_1_s390x.whl", hash = "sha256:572c3763a264ba47b3cf708a44ce965d98555f618ca42c926a9c1616d8f34269"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-musllinux_1_1_x86_64.whl", hash = "sha256:fd1abc0d89e30cc4e02e4064dc67fcc51bd941eb395c502aac3ec19fab46b519"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-win32.whl", hash = "sha256:3d47fa203a7bd9c5b6cee4736ee84ca03b8ef23193c0d1ca99b5089f72645c73"}, + {file = "charset_normalizer-3.3.2-cp310-cp310-win_amd64.whl", hash = "sha256:10955842570876604d404661fbccbc9c7e684caf432c09c715ec38fbae45ae09"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-macosx_10_9_universal2.whl", hash = "sha256:802fe99cca7457642125a8a88a084cef28ff0cf9407060f7b93dca5aa25480db"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-macosx_10_9_x86_64.whl", hash = "sha256:573f6eac48f4769d667c4442081b1794f52919e7edada77495aaed9236d13a96"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-macosx_11_0_arm64.whl", hash = "sha256:549a3a73da901d5bc3ce8d24e0600d1fa85524c10287f6004fbab87672bf3e1e"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:f27273b60488abe721a075bcca6d7f3964f9f6f067c8c4c605743023d7d3944f"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-manylinux_2_17_ppc64le.manylinux2014_ppc64le.whl", hash = "sha256:1ceae2f17a9c33cb48e3263960dc5fc8005351ee19db217e9b1bb15d28c02574"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-manylinux_2_17_s390x.manylinux2014_s390x.whl", hash = "sha256:65f6f63034100ead094b8744b3b97965785388f308a64cf8d7c34f2f2e5be0c4"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:753f10e867343b4511128c6ed8c82f7bec3bd026875576dfd88483c5c73b2fd8"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:4a78b2b446bd7c934f5dcedc588903fb2f5eec172f3d29e52a9096a43722adfc"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-musllinux_1_1_aarch64.whl", hash = "sha256:e537484df0d8f426ce2afb2d0f8e1c3d0b114b83f8850e5f2fbea0e797bd82ae"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-musllinux_1_1_i686.whl", hash = "sha256:eb6904c354526e758fda7167b33005998fb68c46fbc10e013ca97f21ca5c8887"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-musllinux_1_1_ppc64le.whl", hash = "sha256:deb6be0ac38ece9ba87dea880e438f25ca3eddfac8b002a2ec3d9183a454e8ae"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-musllinux_1_1_s390x.whl", hash = "sha256:4ab2fe47fae9e0f9dee8c04187ce5d09f48eabe611be8259444906793ab7cbce"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-musllinux_1_1_x86_64.whl", hash = "sha256:80402cd6ee291dcb72644d6eac93785fe2c8b9cb30893c1af5b8fdd753b9d40f"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-win32.whl", hash = "sha256:7cd13a2e3ddeed6913a65e66e94b51d80a041145a026c27e6bb76c31a853c6ab"}, + {file = "charset_normalizer-3.3.2-cp311-cp311-win_amd64.whl", hash = "sha256:663946639d296df6a2bb2aa51b60a2454ca1cb29835324c640dafb5ff2131a77"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-macosx_10_9_universal2.whl", hash = "sha256:0b2b64d2bb6d3fb9112bafa732def486049e63de9618b5843bcdd081d8144cd8"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-macosx_10_9_x86_64.whl", hash = "sha256:ddbb2551d7e0102e7252db79ba445cdab71b26640817ab1e3e3648dad515003b"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-macosx_11_0_arm64.whl", hash = "sha256:55086ee1064215781fff39a1af09518bc9255b50d6333f2e4c74ca09fac6a8f6"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:8f4a014bc36d3c57402e2977dada34f9c12300af536839dc38c0beab8878f38a"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-manylinux_2_17_ppc64le.manylinux2014_ppc64le.whl", hash = "sha256:a10af20b82360ab00827f916a6058451b723b4e65030c5a18577c8b2de5b3389"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-manylinux_2_17_s390x.manylinux2014_s390x.whl", hash = "sha256:8d756e44e94489e49571086ef83b2bb8ce311e730092d2c34ca8f7d925cb20aa"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:90d558489962fd4918143277a773316e56c72da56ec7aa3dc3dbbe20fdfed15b"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:6ac7ffc7ad6d040517be39eb591cac5ff87416c2537df6ba3cba3bae290c0fed"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-musllinux_1_1_aarch64.whl", hash = "sha256:7ed9e526742851e8d5cc9e6cf41427dfc6068d4f5a3bb03659444b4cabf6bc26"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-musllinux_1_1_i686.whl", hash = "sha256:8bdb58ff7ba23002a4c5808d608e4e6c687175724f54a5dade5fa8c67b604e4d"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-musllinux_1_1_ppc64le.whl", hash = "sha256:6b3251890fff30ee142c44144871185dbe13b11bab478a88887a639655be1068"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-musllinux_1_1_s390x.whl", hash = "sha256:b4a23f61ce87adf89be746c8a8974fe1c823c891d8f86eb218bb957c924bb143"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-musllinux_1_1_x86_64.whl", hash = "sha256:efcb3f6676480691518c177e3b465bcddf57cea040302f9f4e6e191af91174d4"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-win32.whl", hash = "sha256:d965bba47ddeec8cd560687584e88cf699fd28f192ceb452d1d7ee807c5597b7"}, + {file = "charset_normalizer-3.3.2-cp312-cp312-win_amd64.whl", hash = "sha256:96b02a3dc4381e5494fad39be677abcb5e6634bf7b4fa83a6dd3112607547001"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-macosx_10_9_x86_64.whl", hash = "sha256:95f2a5796329323b8f0512e09dbb7a1860c46a39da62ecb2324f116fa8fdc85c"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:c002b4ffc0be611f0d9da932eb0f704fe2602a9a949d1f738e4c34c75b0863d5"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-manylinux_2_17_ppc64le.manylinux2014_ppc64le.whl", hash = "sha256:a981a536974bbc7a512cf44ed14938cf01030a99e9b3a06dd59578882f06f985"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-manylinux_2_17_s390x.manylinux2014_s390x.whl", hash = "sha256:3287761bc4ee9e33561a7e058c72ac0938c4f57fe49a09eae428fd88aafe7bb6"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:42cb296636fcc8b0644486d15c12376cb9fa75443e00fb25de0b8602e64c1714"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:0a55554a2fa0d408816b3b5cedf0045f4b8e1a6065aec45849de2d6f3f8e9786"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-musllinux_1_1_aarch64.whl", hash = "sha256:c083af607d2515612056a31f0a8d9e0fcb5876b7bfc0abad3ecd275bc4ebc2d5"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-musllinux_1_1_i686.whl", hash = "sha256:87d1351268731db79e0f8e745d92493ee2841c974128ef629dc518b937d9194c"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-musllinux_1_1_ppc64le.whl", hash = "sha256:bd8f7df7d12c2db9fab40bdd87a7c09b1530128315d047a086fa3ae3435cb3a8"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-musllinux_1_1_s390x.whl", hash = "sha256:c180f51afb394e165eafe4ac2936a14bee3eb10debc9d9e4db8958fe36afe711"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-musllinux_1_1_x86_64.whl", hash = "sha256:8c622a5fe39a48f78944a87d4fb8a53ee07344641b0562c540d840748571b811"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-win32.whl", hash = "sha256:db364eca23f876da6f9e16c9da0df51aa4f104a972735574842618b8c6d999d4"}, + {file = "charset_normalizer-3.3.2-cp37-cp37m-win_amd64.whl", hash = "sha256:86216b5cee4b06df986d214f664305142d9c76df9b6512be2738aa72a2048f99"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-macosx_10_9_universal2.whl", hash = "sha256:6463effa3186ea09411d50efc7d85360b38d5f09b870c48e4600f63af490e56a"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-macosx_10_9_x86_64.whl", hash = "sha256:6c4caeef8fa63d06bd437cd4bdcf3ffefe6738fb1b25951440d80dc7df8c03ac"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-macosx_11_0_arm64.whl", hash = "sha256:37e55c8e51c236f95b033f6fb391d7d7970ba5fe7ff453dad675e88cf303377a"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:fb69256e180cb6c8a894fee62b3afebae785babc1ee98b81cdf68bbca1987f33"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-manylinux_2_17_ppc64le.manylinux2014_ppc64le.whl", hash = "sha256:ae5f4161f18c61806f411a13b0310bea87f987c7d2ecdbdaad0e94eb2e404238"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-manylinux_2_17_s390x.manylinux2014_s390x.whl", hash = "sha256:b2b0a0c0517616b6869869f8c581d4eb2dd83a4d79e0ebcb7d373ef9956aeb0a"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:45485e01ff4d3630ec0d9617310448a8702f70e9c01906b0d0118bdf9d124cf2"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:eb00ed941194665c332bf8e078baf037d6c35d7c4f3102ea2d4f16ca94a26dc8"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-musllinux_1_1_aarch64.whl", hash = "sha256:2127566c664442652f024c837091890cb1942c30937add288223dc895793f898"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-musllinux_1_1_i686.whl", hash = "sha256:a50aebfa173e157099939b17f18600f72f84eed3049e743b68ad15bd69b6bf99"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-musllinux_1_1_ppc64le.whl", hash = "sha256:4d0d1650369165a14e14e1e47b372cfcb31d6ab44e6e33cb2d4e57265290044d"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-musllinux_1_1_s390x.whl", hash = "sha256:923c0c831b7cfcb071580d3f46c4baf50f174be571576556269530f4bbd79d04"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-musllinux_1_1_x86_64.whl", hash = "sha256:06a81e93cd441c56a9b65d8e1d043daeb97a3d0856d177d5c90ba85acb3db087"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-win32.whl", hash = "sha256:6ef1d82a3af9d3eecdba2321dc1b3c238245d890843e040e41e470ffa64c3e25"}, + {file = "charset_normalizer-3.3.2-cp38-cp38-win_amd64.whl", hash = "sha256:eb8821e09e916165e160797a6c17edda0679379a4be5c716c260e836e122f54b"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-macosx_10_9_universal2.whl", hash = "sha256:c235ebd9baae02f1b77bcea61bce332cb4331dc3617d254df3323aa01ab47bd4"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-macosx_10_9_x86_64.whl", hash = "sha256:5b4c145409bef602a690e7cfad0a15a55c13320ff7a3ad7ca59c13bb8ba4d45d"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-macosx_11_0_arm64.whl", hash = "sha256:68d1f8a9e9e37c1223b656399be5d6b448dea850bed7d0f87a8311f1ff3dabb0"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:22afcb9f253dac0696b5a4be4a1c0f8762f8239e21b99680099abd9b2b1b2269"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-manylinux_2_17_ppc64le.manylinux2014_ppc64le.whl", hash = "sha256:e27ad930a842b4c5eb8ac0016b0a54f5aebbe679340c26101df33424142c143c"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-manylinux_2_17_s390x.manylinux2014_s390x.whl", hash = "sha256:1f79682fbe303db92bc2b1136016a38a42e835d932bab5b3b1bfcfbf0640e519"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:b261ccdec7821281dade748d088bb6e9b69e6d15b30652b74cbbac25e280b796"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:122c7fa62b130ed55f8f285bfd56d5f4b4a5b503609d181f9ad85e55c89f4185"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-musllinux_1_1_aarch64.whl", hash = "sha256:d0eccceffcb53201b5bfebb52600a5fb483a20b61da9dbc885f8b103cbe7598c"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-musllinux_1_1_i686.whl", hash = "sha256:9f96df6923e21816da7e0ad3fd47dd8f94b2a5ce594e00677c0013018b813458"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-musllinux_1_1_ppc64le.whl", hash = "sha256:7f04c839ed0b6b98b1a7501a002144b76c18fb1c1850c8b98d458ac269e26ed2"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-musllinux_1_1_s390x.whl", hash = "sha256:34d1c8da1e78d2e001f363791c98a272bb734000fcef47a491c1e3b0505657a8"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-musllinux_1_1_x86_64.whl", hash = "sha256:ff8fa367d09b717b2a17a052544193ad76cd49979c805768879cb63d9ca50561"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-win32.whl", hash = "sha256:aed38f6e4fb3f5d6bf81bfa990a07806be9d83cf7bacef998ab1a9bd660a581f"}, + {file = "charset_normalizer-3.3.2-cp39-cp39-win_amd64.whl", hash = "sha256:b01b88d45a6fcb69667cd6d2f7a9aeb4bf53760d7fc536bf679ec94fe9f3ff3d"}, + {file = "charset_normalizer-3.3.2-py3-none-any.whl", hash = "sha256:3e4d1f6587322d2788836a99c69062fbb091331ec940e02d12d179c1d53e25fc"}, +] + +[[package]] +name = "colorama" +version = "0.4.6" +description = "Cross-platform colored terminal text." +optional = false +python-versions = "!=3.0.*,!=3.1.*,!=3.2.*,!=3.3.*,!=3.4.*,!=3.5.*,!=3.6.*,>=2.7" +files = [ + {file = "colorama-0.4.6-py2.py3-none-any.whl", hash = "sha256:4f1d9991f5acc0ca119f9d443620b77f9d6b33703e51011c16baf57afb285fc6"}, + {file = "colorama-0.4.6.tar.gz", hash = "sha256:08695f5cb7ed6e0531a20572697297273c47b8cae5a63ffc6d6ed5c201be6e44"}, +] + +[[package]] +name = "docutils" +version = "0.19" +description = "Docutils -- Python Documentation Utilities" +optional = false +python-versions = ">=3.7" +files = [ + {file = "docutils-0.19-py3-none-any.whl", hash = "sha256:5e1de4d849fee02c63b040a4a3fd567f4ab104defd8a5511fbbc24a8a017efbc"}, + {file = "docutils-0.19.tar.gz", hash = "sha256:33995a6753c30b7f577febfc2c50411fec6aac7f7ffeb7c4cfe5991072dcf9e6"}, +] + +[[package]] +name = "exceptiongroup" +version = "1.2.1" +description = "Backport of PEP 654 (exception groups)" +optional = false +python-versions = ">=3.7" +files = [ + {file = "exceptiongroup-1.2.1-py3-none-any.whl", hash = "sha256:5258b9ed329c5bbdd31a309f53cbfb0b155341807f6ff7606a1e801a891b29ad"}, + {file = "exceptiongroup-1.2.1.tar.gz", hash = "sha256:a4785e48b045528f5bfe627b6ad554ff32def154f42372786903b7abcfe1aa16"}, +] + +[package.extras] +test = ["pytest (>=6)"] + +[[package]] +name = "fsspec" +version = "2023.12.2" +description = "File-system specification" +optional = false +python-versions = ">=3.8" +files = [ + {file = "fsspec-2023.12.2-py3-none-any.whl", hash = "sha256:d800d87f72189a745fa3d6b033b9dc4a34ad069f60ca60b943a63599f5501960"}, + {file = "fsspec-2023.12.2.tar.gz", hash = "sha256:8548d39e8810b59c38014934f6b31e57f40c1b20f911f4cc2b85389c7e9bf0cb"}, +] + +[package.extras] +abfs = ["adlfs"] +adl = ["adlfs"] +arrow = ["pyarrow (>=1)"] +dask = ["dask", "distributed"] +devel = ["pytest", "pytest-cov"] +dropbox = ["dropbox", "dropboxdrivefs", "requests"] +full = ["adlfs", "aiohttp (!=4.0.0a0,!=4.0.0a1)", "dask", "distributed", "dropbox", "dropboxdrivefs", "fusepy", "gcsfs", "libarchive-c", "ocifs", "panel", "paramiko", "pyarrow (>=1)", "pygit2", "requests", "s3fs", "smbprotocol", "tqdm"] +fuse = ["fusepy"] +gcs = ["gcsfs"] +git = ["pygit2"] +github = ["requests"] +gs = ["gcsfs"] +gui = ["panel"] +hdfs = ["pyarrow (>=1)"] +http = ["aiohttp (!=4.0.0a0,!=4.0.0a1)", "requests"] +libarchive = ["libarchive-c"] +oci = ["ocifs"] +s3 = ["s3fs"] +sftp = ["paramiko"] +smb = ["smbprotocol"] +ssh = ["paramiko"] +tqdm = ["tqdm"] + +[[package]] +name = "gitdb" +version = "4.0.11" +description = "Git Object Database" +optional = false +python-versions = ">=3.7" +files = [ + {file = "gitdb-4.0.11-py3-none-any.whl", hash = "sha256:81a3407ddd2ee8df444cbacea00e2d038e40150acfa3001696fe0dcf1d3adfa4"}, + {file = "gitdb-4.0.11.tar.gz", hash = "sha256:bf5421126136d6d0af55bc1e7c1af1c397a34f5b7bd79e776cd3e89785c2b04b"}, +] + +[package.dependencies] +smmap = ">=3.0.1,<6" + +[[package]] +name = "gitpython" +version = "3.1.43" +description = "GitPython is a Python library used to interact with Git repositories" +optional = false +python-versions = ">=3.7" +files = [ + {file = "GitPython-3.1.43-py3-none-any.whl", hash = "sha256:eec7ec56b92aad751f9912a73404bc02ba212a23adb2c7098ee668417051a1ff"}, + {file = "GitPython-3.1.43.tar.gz", hash = "sha256:35f314a9f878467f5453cc1fee295c3e18e52f1b99f10f6cf5b1682e968a9e7c"}, +] + +[package.dependencies] +gitdb = ">=4.0.1,<5" + +[package.extras] +doc = ["sphinx (==4.3.2)", "sphinx-autodoc-typehints", "sphinx-rtd-theme", "sphinxcontrib-applehelp (>=1.0.2,<=1.0.4)", "sphinxcontrib-devhelp (==1.0.2)", "sphinxcontrib-htmlhelp (>=2.0.0,<=2.0.1)", "sphinxcontrib-qthelp (==1.0.3)", "sphinxcontrib-serializinghtml (==1.1.5)"] +test = ["coverage[toml]", "ddt (>=1.1.1,!=1.4.3)", "mock", "mypy", "pre-commit", "pytest (>=7.3.1)", "pytest-cov", "pytest-instafail", "pytest-mock", "pytest-sugar", "typing-extensions"] + +[[package]] +name = "idna" +version = "3.7" +description = "Internationalized Domain Names in Applications (IDNA)" +optional = false +python-versions = ">=3.5" +files = [ + {file = "idna-3.7-py3-none-any.whl", hash = "sha256:82fee1fc78add43492d3a1898bfa6d8a904cc97d8427f683ed8e798d07761aa0"}, + {file = "idna-3.7.tar.gz", hash = "sha256:028ff3aadf0609c1fd278d8ea3089299412a7a8b9bd005dd08b9f8285bcb5cfc"}, +] + +[[package]] +name = "imagesize" +version = "1.4.1" +description = "Getting image size from png/jpeg/jpeg2000/gif file" +optional = false +python-versions = ">=2.7, !=3.0.*, !=3.1.*, !=3.2.*, !=3.3.*" +files = [ + {file = "imagesize-1.4.1-py2.py3-none-any.whl", hash = "sha256:0d8d18d08f840c19d0ee7ca1fd82490fdc3729b7ac93f49870406ddde8ef8d8b"}, + {file = "imagesize-1.4.1.tar.gz", hash = "sha256:69150444affb9cb0d5cc5a92b3676f0b2fb7cd9ae39e947a5e11a36b4497cd4a"}, +] + +[[package]] +name = "importlib-metadata" +version = "8.0.0" +description = "Read metadata from Python packages" +optional = false +python-versions = ">=3.8" +files = [ + {file = "importlib_metadata-8.0.0-py3-none-any.whl", hash = "sha256:15584cf2b1bf449d98ff8a6ff1abef57bf20f3ac6454f431736cd3e660921b2f"}, + {file = "importlib_metadata-8.0.0.tar.gz", hash = "sha256:188bd24e4c346d3f0a933f275c2fec67050326a856b9a359881d7c2a697e8812"}, +] + +[package.dependencies] +zipp = ">=0.5" + +[package.extras] +doc = ["furo", "jaraco.packaging (>=9.3)", "jaraco.tidelift (>=1.4)", "rst.linker (>=1.9)", "sphinx (>=3.5)", "sphinx-lint"] +perf = ["ipython"] +test = ["flufl.flake8", "importlib-resources (>=1.3)", "jaraco.test (>=5.4)", "packaging", "pyfakefs", "pytest (>=6,!=8.1.*)", "pytest-checkdocs (>=2.4)", "pytest-cov", "pytest-enabler (>=2.2)", "pytest-mypy", "pytest-perf (>=0.9.2)", "pytest-ruff (>=0.2.1)"] + +[[package]] +name = "iniconfig" +version = "2.0.0" +description = "brain-dead simple config-ini parsing" +optional = false +python-versions = ">=3.7" +files = [ + {file = "iniconfig-2.0.0-py3-none-any.whl", hash = "sha256:b6a85871a79d2e3b22d2d1b94ac2824226a63c6b741c88f7ae975f18b6778374"}, + {file = "iniconfig-2.0.0.tar.gz", hash = "sha256:2d91e135bf72d31a410b17c16da610a82cb55f6b0477d1a902134b24a455b8b3"}, +] + +[[package]] +name = "jinja2" +version = "3.1.4" +description = "A very fast and expressive template engine." +optional = false +python-versions = ">=3.7" +files = [ + {file = "jinja2-3.1.4-py3-none-any.whl", hash = "sha256:bc5dd2abb727a5319567b7a813e6a2e7318c39f4f487cfe6c89c6f9c7d25197d"}, + {file = "jinja2-3.1.4.tar.gz", hash = "sha256:4a3aee7acbbe7303aede8e9648d13b8bf88a429282aa6122a993f0ac800cb369"}, +] + +[package.dependencies] +MarkupSafe = ">=2.0" + +[package.extras] +i18n = ["Babel (>=2.7)"] + +[[package]] +name = "markupsafe" +version = "2.1.5" +description = "Safely add untrusted strings to HTML/XML markup." +optional = false +python-versions = ">=3.7" +files = [ + {file = "MarkupSafe-2.1.5-cp310-cp310-macosx_10_9_universal2.whl", hash = "sha256:a17a92de5231666cfbe003f0e4b9b3a7ae3afb1ec2845aadc2bacc93ff85febc"}, + {file = "MarkupSafe-2.1.5-cp310-cp310-macosx_10_9_x86_64.whl", hash = "sha256:72b6be590cc35924b02c78ef34b467da4ba07e4e0f0454a2c5907f473fc50ce5"}, + {file = "MarkupSafe-2.1.5-cp310-cp310-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:e61659ba32cf2cf1481e575d0462554625196a1f2fc06a1c777d3f48e8865d46"}, + {file = "MarkupSafe-2.1.5-cp310-cp310-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:2174c595a0d73a3080ca3257b40096db99799265e1c27cc5a610743acd86d62f"}, + {file = "MarkupSafe-2.1.5-cp310-cp310-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:ae2ad8ae6ebee9d2d94b17fb62763125f3f374c25618198f40cbb8b525411900"}, + {file = "MarkupSafe-2.1.5-cp310-cp310-musllinux_1_1_aarch64.whl", hash = "sha256:075202fa5b72c86ad32dc7d0b56024ebdbcf2048c0ba09f1cde31bfdd57bcfff"}, + {file = "MarkupSafe-2.1.5-cp310-cp310-musllinux_1_1_i686.whl", hash = "sha256:598e3276b64aff0e7b3451b72e94fa3c238d452e7ddcd893c3ab324717456bad"}, + {file = "MarkupSafe-2.1.5-cp310-cp310-musllinux_1_1_x86_64.whl", hash = "sha256:fce659a462a1be54d2ffcacea5e3ba2d74daa74f30f5f143fe0c58636e355fdd"}, + {file = "MarkupSafe-2.1.5-cp310-cp310-win32.whl", hash = "sha256:d9fad5155d72433c921b782e58892377c44bd6252b5af2f67f16b194987338a4"}, + {file = "MarkupSafe-2.1.5-cp310-cp310-win_amd64.whl", hash = "sha256:bf50cd79a75d181c9181df03572cdce0fbb75cc353bc350712073108cba98de5"}, + {file = "MarkupSafe-2.1.5-cp311-cp311-macosx_10_9_universal2.whl", hash = "sha256:629ddd2ca402ae6dbedfceeba9c46d5f7b2a61d9749597d4307f943ef198fc1f"}, + {file = "MarkupSafe-2.1.5-cp311-cp311-macosx_10_9_x86_64.whl", hash = "sha256:5b7b716f97b52c5a14bffdf688f971b2d5ef4029127f1ad7a513973cfd818df2"}, + {file = "MarkupSafe-2.1.5-cp311-cp311-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:6ec585f69cec0aa07d945b20805be741395e28ac1627333b1c5b0105962ffced"}, + {file = "MarkupSafe-2.1.5-cp311-cp311-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:b91c037585eba9095565a3556f611e3cbfaa42ca1e865f7b8015fe5c7336d5a5"}, + {file = "MarkupSafe-2.1.5-cp311-cp311-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:7502934a33b54030eaf1194c21c692a534196063db72176b0c4028e140f8f32c"}, + {file = "MarkupSafe-2.1.5-cp311-cp311-musllinux_1_1_aarch64.whl", hash = "sha256:0e397ac966fdf721b2c528cf028494e86172b4feba51d65f81ffd65c63798f3f"}, + {file = "MarkupSafe-2.1.5-cp311-cp311-musllinux_1_1_i686.whl", hash = "sha256:c061bb86a71b42465156a3ee7bd58c8c2ceacdbeb95d05a99893e08b8467359a"}, + {file = "MarkupSafe-2.1.5-cp311-cp311-musllinux_1_1_x86_64.whl", hash = "sha256:3a57fdd7ce31c7ff06cdfbf31dafa96cc533c21e443d57f5b1ecc6cdc668ec7f"}, + {file = "MarkupSafe-2.1.5-cp311-cp311-win32.whl", hash = "sha256:397081c1a0bfb5124355710fe79478cdbeb39626492b15d399526ae53422b906"}, + {file = "MarkupSafe-2.1.5-cp311-cp311-win_amd64.whl", hash = "sha256:2b7c57a4dfc4f16f7142221afe5ba4e093e09e728ca65c51f5620c9aaeb9a617"}, + {file = "MarkupSafe-2.1.5-cp312-cp312-macosx_10_9_universal2.whl", hash = "sha256:8dec4936e9c3100156f8a2dc89c4b88d5c435175ff03413b443469c7c8c5f4d1"}, + {file = "MarkupSafe-2.1.5-cp312-cp312-macosx_10_9_x86_64.whl", hash = "sha256:3c6b973f22eb18a789b1460b4b91bf04ae3f0c4234a0a6aa6b0a92f6f7b951d4"}, + {file = "MarkupSafe-2.1.5-cp312-cp312-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:ac07bad82163452a6884fe8fa0963fb98c2346ba78d779ec06bd7a6262132aee"}, + {file = "MarkupSafe-2.1.5-cp312-cp312-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:f5dfb42c4604dddc8e4305050aa6deb084540643ed5804d7455b5df8fe16f5e5"}, + {file = "MarkupSafe-2.1.5-cp312-cp312-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:ea3d8a3d18833cf4304cd2fc9cbb1efe188ca9b5efef2bdac7adc20594a0e46b"}, + {file = "MarkupSafe-2.1.5-cp312-cp312-musllinux_1_1_aarch64.whl", hash = "sha256:d050b3361367a06d752db6ead6e7edeb0009be66bc3bae0ee9d97fb326badc2a"}, + {file = "MarkupSafe-2.1.5-cp312-cp312-musllinux_1_1_i686.whl", hash = "sha256:bec0a414d016ac1a18862a519e54b2fd0fc8bbfd6890376898a6c0891dd82e9f"}, + {file = "MarkupSafe-2.1.5-cp312-cp312-musllinux_1_1_x86_64.whl", hash = "sha256:58c98fee265677f63a4385256a6d7683ab1832f3ddd1e66fe948d5880c21a169"}, + {file = "MarkupSafe-2.1.5-cp312-cp312-win32.whl", hash = "sha256:8590b4ae07a35970728874632fed7bd57b26b0102df2d2b233b6d9d82f6c62ad"}, + {file = "MarkupSafe-2.1.5-cp312-cp312-win_amd64.whl", hash = "sha256:823b65d8706e32ad2df51ed89496147a42a2a6e01c13cfb6ffb8b1e92bc910bb"}, + {file = "MarkupSafe-2.1.5-cp37-cp37m-macosx_10_9_x86_64.whl", hash = "sha256:c8b29db45f8fe46ad280a7294f5c3ec36dbac9491f2d1c17345be8e69cc5928f"}, + {file = "MarkupSafe-2.1.5-cp37-cp37m-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:ec6a563cff360b50eed26f13adc43e61bc0c04d94b8be985e6fb24b81f6dcfdf"}, + {file = "MarkupSafe-2.1.5-cp37-cp37m-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:a549b9c31bec33820e885335b451286e2969a2d9e24879f83fe904a5ce59d70a"}, + {file = "MarkupSafe-2.1.5-cp37-cp37m-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:4f11aa001c540f62c6166c7726f71f7573b52c68c31f014c25cc7901deea0b52"}, + {file = "MarkupSafe-2.1.5-cp37-cp37m-musllinux_1_1_aarch64.whl", hash = "sha256:7b2e5a267c855eea6b4283940daa6e88a285f5f2a67f2220203786dfa59b37e9"}, + {file = "MarkupSafe-2.1.5-cp37-cp37m-musllinux_1_1_i686.whl", hash = "sha256:2d2d793e36e230fd32babe143b04cec8a8b3eb8a3122d2aceb4a371e6b09b8df"}, + {file = "MarkupSafe-2.1.5-cp37-cp37m-musllinux_1_1_x86_64.whl", hash = "sha256:ce409136744f6521e39fd8e2a24c53fa18ad67aa5bc7c2cf83645cce5b5c4e50"}, + {file = "MarkupSafe-2.1.5-cp37-cp37m-win32.whl", hash = "sha256:4096e9de5c6fdf43fb4f04c26fb114f61ef0bf2e5604b6ee3019d51b69e8c371"}, + {file = "MarkupSafe-2.1.5-cp37-cp37m-win_amd64.whl", hash = "sha256:4275d846e41ecefa46e2015117a9f491e57a71ddd59bbead77e904dc02b1bed2"}, + {file = "MarkupSafe-2.1.5-cp38-cp38-macosx_10_9_universal2.whl", hash = "sha256:656f7526c69fac7f600bd1f400991cc282b417d17539a1b228617081106feb4a"}, + {file = "MarkupSafe-2.1.5-cp38-cp38-macosx_10_9_x86_64.whl", hash = "sha256:97cafb1f3cbcd3fd2b6fbfb99ae11cdb14deea0736fc2b0952ee177f2b813a46"}, + {file = "MarkupSafe-2.1.5-cp38-cp38-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:1f3fbcb7ef1f16e48246f704ab79d79da8a46891e2da03f8783a5b6fa41a9532"}, + {file = "MarkupSafe-2.1.5-cp38-cp38-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:fa9db3f79de01457b03d4f01b34cf91bc0048eb2c3846ff26f66687c2f6d16ab"}, + {file = "MarkupSafe-2.1.5-cp38-cp38-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:ffee1f21e5ef0d712f9033568f8344d5da8cc2869dbd08d87c84656e6a2d2f68"}, + {file = "MarkupSafe-2.1.5-cp38-cp38-musllinux_1_1_aarch64.whl", hash = "sha256:5dedb4db619ba5a2787a94d877bc8ffc0566f92a01c0ef214865e54ecc9ee5e0"}, + {file = "MarkupSafe-2.1.5-cp38-cp38-musllinux_1_1_i686.whl", hash = "sha256:30b600cf0a7ac9234b2638fbc0fb6158ba5bdcdf46aeb631ead21248b9affbc4"}, + {file = "MarkupSafe-2.1.5-cp38-cp38-musllinux_1_1_x86_64.whl", hash = "sha256:8dd717634f5a044f860435c1d8c16a270ddf0ef8588d4887037c5028b859b0c3"}, + {file = "MarkupSafe-2.1.5-cp38-cp38-win32.whl", hash = "sha256:daa4ee5a243f0f20d528d939d06670a298dd39b1ad5f8a72a4275124a7819eff"}, + {file = "MarkupSafe-2.1.5-cp38-cp38-win_amd64.whl", hash = "sha256:619bc166c4f2de5caa5a633b8b7326fbe98e0ccbfacabd87268a2b15ff73a029"}, + {file = "MarkupSafe-2.1.5-cp39-cp39-macosx_10_9_universal2.whl", hash = "sha256:7a68b554d356a91cce1236aa7682dc01df0edba8d043fd1ce607c49dd3c1edcf"}, + {file = "MarkupSafe-2.1.5-cp39-cp39-macosx_10_9_x86_64.whl", hash = "sha256:db0b55e0f3cc0be60c1f19efdde9a637c32740486004f20d1cff53c3c0ece4d2"}, + {file = "MarkupSafe-2.1.5-cp39-cp39-manylinux_2_17_aarch64.manylinux2014_aarch64.whl", hash = "sha256:3e53af139f8579a6d5f7b76549125f0d94d7e630761a2111bc431fd820e163b8"}, + {file = "MarkupSafe-2.1.5-cp39-cp39-manylinux_2_17_x86_64.manylinux2014_x86_64.whl", hash = "sha256:17b950fccb810b3293638215058e432159d2b71005c74371d784862b7e4683f3"}, + {file = "MarkupSafe-2.1.5-cp39-cp39-manylinux_2_5_i686.manylinux1_i686.manylinux_2_17_i686.manylinux2014_i686.whl", hash = "sha256:4c31f53cdae6ecfa91a77820e8b151dba54ab528ba65dfd235c80b086d68a465"}, + {file = "MarkupSafe-2.1.5-cp39-cp39-musllinux_1_1_aarch64.whl", hash = "sha256:bff1b4290a66b490a2f4719358c0cdcd9bafb6b8f061e45c7a2460866bf50c2e"}, + {file = "MarkupSafe-2.1.5-cp39-cp39-musllinux_1_1_i686.whl", hash = "sha256:bc1667f8b83f48511b94671e0e441401371dfd0f0a795c7daa4a3cd1dde55bea"}, + {file = "MarkupSafe-2.1.5-cp39-cp39-musllinux_1_1_x86_64.whl", hash = "sha256:5049256f536511ee3f7e1b3f87d1d1209d327e818e6ae1365e8653d7e3abb6a6"}, + {file = "MarkupSafe-2.1.5-cp39-cp39-win32.whl", hash = "sha256:00e046b6dd71aa03a41079792f8473dc494d564611a8f89bbbd7cb93295ebdcf"}, + {file = "MarkupSafe-2.1.5-cp39-cp39-win_amd64.whl", hash = "sha256:fa173ec60341d6bb97a89f5ea19c85c5643c1e7dedebc22f5181eb73573142c5"}, + {file = "MarkupSafe-2.1.5.tar.gz", hash = "sha256:d283d37a890ba4c1ae73ffadf8046435c76e7bc2247bbb63c00bd1a709c6544b"}, +] + +[[package]] +name = "packaging" +version = "24.1" +description = "Core utilities for Python packages" +optional = false +python-versions = ">=3.8" +files = [ + {file = "packaging-24.1-py3-none-any.whl", hash = "sha256:5b8f2217dbdbd2f7f384c41c628544e6d52f2d0f53c6d0c3ea61aa5d1d7ff124"}, + {file = "packaging-24.1.tar.gz", hash = "sha256:026ed72c8ed3fcce5bf8950572258698927fd1dbda10a5e981cdf0ac37f4f002"}, +] + +[[package]] +name = "pluggy" +version = "1.5.0" +description = "plugin and hook calling mechanisms for python" +optional = false +python-versions = ">=3.8" +files = [ + {file = "pluggy-1.5.0-py3-none-any.whl", hash = "sha256:44e1ad92c8ca002de6377e165f3e0f1be63266ab4d554740532335b9d75ea669"}, + {file = "pluggy-1.5.0.tar.gz", hash = "sha256:2cffa88e94fdc978c4c574f15f9e59b7f4201d439195c3715ca9e2486f1d0cf1"}, +] + +[package.extras] +dev = ["pre-commit", "tox"] +testing = ["pytest", "pytest-benchmark"] + +[[package]] +name = "pyfakefs" +version = "5.5.0" +description = "pyfakefs implements a fake file system that mocks the Python file system modules." +optional = false +python-versions = ">=3.7" +files = [ + {file = "pyfakefs-5.5.0-py3-none-any.whl", hash = "sha256:8dbf203ab7bef1529f11f7d41b9478b898e95bf9f3b71262163aac07a518cd76"}, + {file = "pyfakefs-5.5.0.tar.gz", hash = "sha256:7448aaa07142f892d0a4eb52a5ed3206a9f02c6599e686cd97d624c18979c154"}, +] + +[[package]] +name = "pygments" +version = "2.18.0" +description = "Pygments is a syntax highlighting package written in Python." +optional = false +python-versions = ">=3.8" +files = [ + {file = "pygments-2.18.0-py3-none-any.whl", hash = "sha256:b8e6aca0523f3ab76fee51799c488e38782ac06eafcf95e7ba832985c8e7b13a"}, + {file = "pygments-2.18.0.tar.gz", hash = "sha256:786ff802f32e91311bff3889f6e9a86e81505fe99f2735bb6d60ae0c5004f199"}, +] + +[package.extras] +windows-terminal = ["colorama (>=0.4.6)"] + +[[package]] +name = "pytest" +version = "8.2.2" +description = "pytest: simple powerful testing with Python" +optional = false +python-versions = ">=3.8" +files = [ + {file = "pytest-8.2.2-py3-none-any.whl", hash = "sha256:c434598117762e2bd304e526244f67bf66bbd7b5d6cf22138be51ff661980343"}, + {file = "pytest-8.2.2.tar.gz", hash = "sha256:de4bb8104e201939ccdc688b27a89a7be2079b22e2bd2b07f806b6ba71117977"}, +] + +[package.dependencies] +colorama = {version = "*", markers = "sys_platform == \"win32\""} +exceptiongroup = {version = ">=1.0.0rc8", markers = "python_version < \"3.11\""} +iniconfig = "*" +packaging = "*" +pluggy = ">=1.5,<2.0" +tomli = {version = ">=1", markers = "python_version < \"3.11\""} + +[package.extras] +dev = ["argcomplete", "attrs (>=19.2)", "hypothesis (>=3.56)", "mock", "pygments (>=2.7.2)", "requests", "setuptools", "xmlschema"] + +[[package]] +name = "pytz" +version = "2024.1" +description = "World timezone definitions, modern and historical" +optional = false +python-versions = "*" +files = [ + {file = "pytz-2024.1-py2.py3-none-any.whl", hash = "sha256:328171f4e3623139da4983451950b28e95ac706e13f3f2630a879749e7a8b319"}, + {file = "pytz-2024.1.tar.gz", hash = "sha256:2a29735ea9c18baf14b448846bde5a48030ed267578472d8955cd0e7443a9812"}, +] + +[[package]] +name = "requests" +version = "2.32.3" +description = "Python HTTP for Humans." +optional = false +python-versions = ">=3.8" +files = [ + {file = "requests-2.32.3-py3-none-any.whl", hash = "sha256:70761cfe03c773ceb22aa2f671b4757976145175cdfca038c02654d061d6dcc6"}, + {file = "requests-2.32.3.tar.gz", hash = "sha256:55365417734eb18255590a9ff9eb97e9e1da868d4ccd6402399eaf68af20a760"}, +] + +[package.dependencies] +certifi = ">=2017.4.17" +charset-normalizer = ">=2,<4" +idna = ">=2.5,<4" +urllib3 = ">=1.21.1,<3" + +[package.extras] +socks = ["PySocks (>=1.5.6,!=1.5.7)"] +use-chardet-on-py3 = ["chardet (>=3.0.2,<6)"] + +[[package]] +name = "smmap" +version = "5.0.1" +description = "A pure Python implementation of a sliding window memory map manager" +optional = false +python-versions = ">=3.7" +files = [ + {file = "smmap-5.0.1-py3-none-any.whl", hash = "sha256:e6d8668fa5f93e706934a62d7b4db19c8d9eb8cf2adbb75ef1b675aa332b69da"}, + {file = "smmap-5.0.1.tar.gz", hash = "sha256:dceeb6c0028fdb6734471eb07c0cd2aae706ccaecab45965ee83f11c8d3b1f62"}, +] + +[[package]] +name = "snowballstemmer" +version = "2.2.0" +description = "This package provides 29 stemmers for 28 languages generated from Snowball algorithms." +optional = false +python-versions = "*" +files = [ + {file = "snowballstemmer-2.2.0-py2.py3-none-any.whl", hash = "sha256:c8e1716e83cc398ae16824e5572ae04e0d9fc2c6b985fb0f900f5f0c96ecba1a"}, + {file = "snowballstemmer-2.2.0.tar.gz", hash = "sha256:09b16deb8547d3412ad7b590689584cd0fe25ec8db3be37788be3810cbf19cb1"}, +] + +[[package]] +name = "sphinx" +version = "5.3.0" +description = "Python documentation generator" +optional = false +python-versions = ">=3.6" +files = [ + {file = "Sphinx-5.3.0.tar.gz", hash = "sha256:51026de0a9ff9fc13c05d74913ad66047e104f56a129ff73e174eb5c3ee794b5"}, + {file = "sphinx-5.3.0-py3-none-any.whl", hash = "sha256:060ca5c9f7ba57a08a1219e547b269fadf125ae25b06b9fa7f66768efb652d6d"}, +] + +[package.dependencies] +alabaster = ">=0.7,<0.8" +babel = ">=2.9" +colorama = {version = ">=0.4.5", markers = "sys_platform == \"win32\""} +docutils = ">=0.14,<0.20" +imagesize = ">=1.3" +importlib-metadata = {version = ">=4.8", markers = "python_version < \"3.10\""} +Jinja2 = ">=3.0" +packaging = ">=21.0" +Pygments = ">=2.12" +requests = ">=2.5.0" +snowballstemmer = ">=2.0" +sphinxcontrib-applehelp = "*" +sphinxcontrib-devhelp = "*" +sphinxcontrib-htmlhelp = ">=2.0.0" +sphinxcontrib-jsmath = "*" +sphinxcontrib-qthelp = "*" +sphinxcontrib-serializinghtml = ">=1.1.5" + +[package.extras] +docs = ["sphinxcontrib-websupport"] +lint = ["docutils-stubs", "flake8 (>=3.5.0)", "flake8-bugbear", "flake8-comprehensions", "flake8-simplify", "isort", "mypy (>=0.981)", "sphinx-lint", "types-requests", "types-typed-ast"] +test = ["cython", "html5lib", "pytest (>=4.6)", "typed_ast"] + +[[package]] +name = "sphinxcontrib-applehelp" +version = "1.0.4" +description = "sphinxcontrib-applehelp is a Sphinx extension which outputs Apple help books" +optional = false +python-versions = ">=3.8" +files = [ + {file = "sphinxcontrib-applehelp-1.0.4.tar.gz", hash = "sha256:828f867945bbe39817c210a1abfd1bc4895c8b73fcaade56d45357a348a07d7e"}, + {file = "sphinxcontrib_applehelp-1.0.4-py3-none-any.whl", hash = "sha256:29d341f67fb0f6f586b23ad80e072c8e6ad0b48417db2bde114a4c9746feb228"}, +] + +[package.extras] +lint = ["docutils-stubs", "flake8", "mypy"] +test = ["pytest"] + +[[package]] +name = "sphinxcontrib-devhelp" +version = "1.0.2" +description = "sphinxcontrib-devhelp is a sphinx extension which outputs Devhelp document." +optional = false +python-versions = ">=3.5" +files = [ + {file = "sphinxcontrib-devhelp-1.0.2.tar.gz", hash = "sha256:ff7f1afa7b9642e7060379360a67e9c41e8f3121f2ce9164266f61b9f4b338e4"}, + {file = "sphinxcontrib_devhelp-1.0.2-py2.py3-none-any.whl", hash = "sha256:8165223f9a335cc1af7ffe1ed31d2871f325254c0423bc0c4c7cd1c1e4734a2e"}, +] + +[package.extras] +lint = ["docutils-stubs", "flake8", "mypy"] +test = ["pytest"] + +[[package]] +name = "sphinxcontrib-htmlhelp" +version = "2.0.1" +description = "sphinxcontrib-htmlhelp is a sphinx extension which renders HTML help files" +optional = false +python-versions = ">=3.8" +files = [ + {file = "sphinxcontrib-htmlhelp-2.0.1.tar.gz", hash = "sha256:0cbdd302815330058422b98a113195c9249825d681e18f11e8b1f78a2f11efff"}, + {file = "sphinxcontrib_htmlhelp-2.0.1-py3-none-any.whl", hash = "sha256:c38cb46dccf316c79de6e5515e1770414b797162b23cd3d06e67020e1d2a6903"}, +] + +[package.extras] +lint = ["docutils-stubs", "flake8", "mypy"] +test = ["html5lib", "pytest"] + +[[package]] +name = "sphinxcontrib-jsmath" +version = "1.0.1" +description = "A sphinx extension which renders display math in HTML via JavaScript" +optional = false +python-versions = ">=3.5" +files = [ + {file = "sphinxcontrib-jsmath-1.0.1.tar.gz", hash = "sha256:a9925e4a4587247ed2191a22df5f6970656cb8ca2bd6284309578f2153e0c4b8"}, + {file = "sphinxcontrib_jsmath-1.0.1-py2.py3-none-any.whl", hash = "sha256:2ec2eaebfb78f3f2078e73666b1415417a116cc848b72e5172e596c871103178"}, +] + +[package.extras] +test = ["flake8", "mypy", "pytest"] + +[[package]] +name = "sphinxcontrib-qthelp" +version = "1.0.3" +description = "sphinxcontrib-qthelp is a sphinx extension which outputs QtHelp document." +optional = false +python-versions = ">=3.5" +files = [ + {file = "sphinxcontrib-qthelp-1.0.3.tar.gz", hash = "sha256:4c33767ee058b70dba89a6fc5c1892c0d57a54be67ddd3e7875a18d14cba5a72"}, + {file = "sphinxcontrib_qthelp-1.0.3-py2.py3-none-any.whl", hash = "sha256:bd9fc24bcb748a8d51fd4ecaade681350aa63009a347a8c14e637895444dfab6"}, +] + +[package.extras] +lint = ["docutils-stubs", "flake8", "mypy"] +test = ["pytest"] + +[[package]] +name = "sphinxcontrib-serializinghtml" +version = "1.1.5" +description = "sphinxcontrib-serializinghtml is a sphinx extension which outputs \"serialized\" HTML files (json and pickle)." +optional = false +python-versions = ">=3.5" +files = [ + {file = "sphinxcontrib-serializinghtml-1.1.5.tar.gz", hash = "sha256:aa5f6de5dfdf809ef505c4895e51ef5c9eac17d0f287933eb49ec495280b6952"}, + {file = "sphinxcontrib_serializinghtml-1.1.5-py2.py3-none-any.whl", hash = "sha256:352a9a00ae864471d3a7ead8d7d79f5fc0b57e8b3f95e9867eb9eb28999b92fd"}, +] + +[package.extras] +lint = ["docutils-stubs", "flake8", "mypy"] +test = ["pytest"] + +[[package]] +name = "tomli" +version = "2.0.1" +description = "A lil' TOML parser" +optional = false +python-versions = ">=3.7" +files = [ + {file = "tomli-2.0.1-py3-none-any.whl", hash = "sha256:939de3e7a6161af0c887ef91b7d41a53e7c5a1ca976325f429cb46ea9bc30ecc"}, + {file = "tomli-2.0.1.tar.gz", hash = "sha256:de526c12914f0c550d15924c62d72abc48d6fe7364aa87328337a31007fe8a4f"}, +] + +[[package]] +name = "urllib3" +version = "2.2.2" +description = "HTTP library with thread-safe connection pooling, file post, and more." +optional = false +python-versions = ">=3.8" +files = [ + {file = "urllib3-2.2.2-py3-none-any.whl", hash = "sha256:a448b2f64d686155468037e1ace9f2d2199776e17f0a46610480d311f73e3472"}, + {file = "urllib3-2.2.2.tar.gz", hash = "sha256:dd505485549a7a552833da5e6063639d0d177c04f23bc3864e41e5dc5f612168"}, +] + +[package.extras] +brotli = ["brotli (>=1.0.9)", "brotlicffi (>=0.8.0)"] +h2 = ["h2 (>=4,<5)"] +socks = ["pysocks (>=1.5.6,!=1.5.7,<2.0)"] +zstd = ["zstandard (>=0.18.0)"] + +[[package]] +name = "wheel" +version = "0.42.0" +description = "A built-package format for Python" +optional = false +python-versions = ">=3.7" +files = [ + {file = "wheel-0.42.0-py3-none-any.whl", hash = "sha256:177f9c9b0d45c47873b619f5b650346d632cdc35fb5e4d25058e09c9e581433d"}, + {file = "wheel-0.42.0.tar.gz", hash = "sha256:c45be39f7882c9d34243236f2d63cbd58039e360f85d0913425fbd7ceea617a8"}, +] + +[package.extras] +test = ["pytest (>=6.0.0)", "setuptools (>=65)"] + +[[package]] +name = "zipp" +version = "3.19.2" +description = "Backport of pathlib-compatible object wrapper for zip files" +optional = false +python-versions = ">=3.8" +files = [ + {file = "zipp-3.19.2-py3-none-any.whl", hash = "sha256:f091755f667055f2d02b32c53771a7a6c8b47e1fdbc4b72a8b9072b3eef8015c"}, + {file = "zipp-3.19.2.tar.gz", hash = "sha256:bf1dcf6450f873a13e952a29504887c89e6de7506209e5b1bcc3460135d4de19"}, +] + +[package.extras] +doc = ["furo", "jaraco.packaging (>=9.3)", "jaraco.tidelift (>=1.4)", "rst.linker (>=1.9)", "sphinx (>=3.5)", "sphinx-lint"] +test = ["big-O", "importlib-resources", "jaraco.functools", "jaraco.itertools", "jaraco.test", "more-itertools", "pytest (>=6,!=8.1.*)", "pytest-checkdocs (>=2.4)", "pytest-cov", "pytest-enabler (>=2.2)", "pytest-ignore-flaky", "pytest-mypy", "pytest-ruff (>=0.2.1)"] + +[metadata] +lock-version = "2.0" +python-versions = "^3.8" +content-hash = "25ee2ae1d74abedde3a6637a60d4a3095ea5cf9731960875741bbc2ba84a475d" diff --git a/.lib/pyproject.toml b/.lib/pyproject.toml new file mode 100644 index 0000000000..95e6076f7f --- /dev/null +++ b/.lib/pyproject.toml @@ -0,0 +1,42 @@ +[tool.poetry] +name = "git-fleximod" +version = "1.0.1" +description = "Extended support for git-submodule and git-sparse-checkout" +authors = ["Jim Edwards "] +maintainers = ["Jim Edwards "] +license = "MIT" +readme = "README.md" +homepage = "https://github.com/jedwards4b/git-fleximod" +keywords = ["git", "submodule", "sparse-checkout"] +packages = [ +{ include = "git_fleximod"}, +{ include = "doc"}, +{ include = "README.md"}, +] + +[tool.poetry.scripts] +git-fleximod = "git_fleximod.git_fleximod:main" +me2flexi = "git_fleximod.metoflexi:_main" +fsspec = "fsspec.fuse:main" + +[tool.poetry.dependencies] +python = "^3.8" +GitPython = "^3.1.0" +sphinx = "^5.0.0" +fsspec = "^2023.12.2" +wheel = "^0.42.0" +pytest = "^8.0.0" +pyfakefs = "^5.3.5" + +[tool.poetry.urls] +"Bug Tracker" = "https://github.com/jedwards4b/git-fleximod/issues" + +[tool.pytest.ini_options] +markers = [ + "skip_after_first: only run on first iteration" +] + +[build-system] +requires = ["poetry-core"] +build-backend = "poetry.core.masonry.api" + diff --git a/.lib/tbump.toml b/.lib/tbump.toml new file mode 100644 index 0000000000..b20c789b6c --- /dev/null +++ b/.lib/tbump.toml @@ -0,0 +1,43 @@ +# Uncomment this if your project is hosted on GitHub: +github_url = "https://github.com/jedwards4b/git-fleximod/" + +[version] +current = "1.0.1" + +# Example of a semver regexp. +# Make sure this matches current_version before +# using tbump +regex = ''' + (?P\d+) + \. + (?P\d+) + \. + (?P\d+) + ''' + +[git] +message_template = "Bump to {new_version}" +tag_template = "v{new_version}" + +# For each file to patch, add a [[file]] config +# section containing the path of the file, relative to the +# tbump.toml location. +[[file]] +src = "git_fleximod/cli.py" + +[[file]] +src = "pyproject.toml" + +# You can specify a list of commands to +# run after the files have been patched +# and before the git commit is made + +# [[before_commit]] +# name = "check changelog" +# cmd = "grep -q {new_version} Changelog.rst" + +# Or run some commands after the git tag and the branch +# have been pushed: +# [[after_push]] +# name = "publish" +# cmd = "./publish.sh" diff --git a/.lib/tests/__init__.py b/.lib/tests/__init__.py new file mode 100644 index 0000000000..4d4c66c78e --- /dev/null +++ b/.lib/tests/__init__.py @@ -0,0 +1,3 @@ +import sys, os + +sys.path.append(os.path.join(os.path.dirname(__file__), os.path.pardir, "src")) diff --git a/.lib/tests/conftest.py b/.lib/tests/conftest.py new file mode 100644 index 0000000000..44d28e1788 --- /dev/null +++ b/.lib/tests/conftest.py @@ -0,0 +1,150 @@ +import pytest +from git_fleximod.gitinterface import GitInterface +import os +import subprocess +import logging +from pathlib import Path + +@pytest.fixture(scope='session') +def logger(): + logging.basicConfig( + level=logging.INFO, format="%(name)s - %(levelname)s - %(message)s", handlers=[logging.StreamHandler()] + ) + logger = logging.getLogger(__name__) + return logger + +all_repos=[ + {"subrepo_path": "modules/test", + "submodule_name": "test_submodule", + "status1" : "test_submodule MPIserial_2.5.0-3-gd82ce7c is out of sync with .gitmodules MPIserial_2.4.0", + "status2" : "test_submodule at tag MPIserial_2.4.0", + "status3" : "test_submodule at tag MPIserial_2.4.0", + "status4" : "test_submodule at tag MPIserial_2.4.0", + "gitmodules_content" : """ + [submodule "test_submodule"] + path = modules/test + url = https://github.com/ESMCI/mpi-serial.git + fxtag = MPIserial_2.4.0 + fxDONOTUSEurl = https://github.com/ESMCI/mpi-serial.git + fxrequired = ToplevelRequired +"""}, + {"subrepo_path": "modules/test_optional", + "submodule_name": "test_optional", + "status1" : "test_optional MPIserial_2.5.0-3-gd82ce7c is out of sync with .gitmodules MPIserial_2.4.0", + "status2" : "test_optional at tag MPIserial_2.4.0", + "status3" : "test_optional not checked out, out of sync at tag MPIserial_2.5.4, expected tag is MPIserial_2.4.0 (optional)", + "status4" : "test_optional at tag MPIserial_2.4.0", + "gitmodules_content": """ + [submodule "test_optional"] + path = modules/test_optional + url = https://github.com/ESMCI/mpi-serial.git + fxtag = MPIserial_2.4.0 + fxDONOTUSEurl = https://github.com/ESMCI/mpi-serial.git + fxrequired = ToplevelOptional +"""}, + {"subrepo_path": "modules/test_alwaysoptional", + "submodule_name": "test_alwaysoptional", + "status1" : "test_alwaysoptional MPIserial_2.3.0 is out of sync with .gitmodules e5cf35c", + "status2" : "test_alwaysoptional at hash e5cf35c", + "status3" : "out of sync at tag MPIserial_2.5.4, expected tag is e5cf35c", + "status4" : "test_alwaysoptional at hash e5cf35c", + "gitmodules_content": """ + [submodule "test_alwaysoptional"] + path = modules/test_alwaysoptional + url = https://github.com/ESMCI/mpi-serial.git + fxtag = e5cf35c + fxDONOTUSEurl = https://github.com/ESMCI/mpi-serial.git + fxrequired = AlwaysOptional +"""}, + {"subrepo_path": "modules/test_sparse", + "submodule_name": "test_sparse", + "status1" : "test_sparse at tag MPIserial_2.5.0", + "status2" : "test_sparse at tag MPIserial_2.5.0", + "status3" : "test_sparse at tag MPIserial_2.5.0", + "status4" : "test_sparse at tag MPIserial_2.5.0", + "gitmodules_content": """ + [submodule "test_sparse"] + path = modules/test_sparse + url = https://github.com/ESMCI/mpi-serial.git + fxtag = MPIserial_2.5.0 + fxDONOTUSEurl = https://github.com/ESMCI/mpi-serial.git + fxrequired = AlwaysRequired + fxsparse = ../.sparse_file_list +"""}, +] +@pytest.fixture(params=all_repos) + +def shared_repos(request): + return request.param + +@pytest.fixture +def get_all_repos(): + return all_repos + +def write_sparse_checkout_file(fp): + sparse_content = """m4 +""" + fp.write_text(sparse_content) + +@pytest.fixture +def test_repo(shared_repos, tmp_path, logger): + subrepo_path = shared_repos["subrepo_path"] + submodule_name = shared_repos["submodule_name"] + test_dir = tmp_path / "testrepo" + test_dir.mkdir() + str_path = str(test_dir) + gitp = GitInterface(str_path, logger) + assert test_dir.joinpath(".git").is_dir() + (test_dir / "modules").mkdir() + if "sparse" in submodule_name: + (test_dir / subrepo_path).mkdir() + # Add the sparse checkout file + write_sparse_checkout_file(test_dir / "modules" / ".sparse_file_list") + gitp.git_operation("add","modules/.sparse_file_list") + else: + gitp = GitInterface(str(test_dir), logger) + gitp.git_operation("submodule", "add", "--depth","1","--name", submodule_name, "https://github.com/ESMCI/mpi-serial.git", subrepo_path) + assert test_dir.joinpath(".gitmodules").is_file() + gitp.git_operation("add",subrepo_path) + gitp.git_operation("commit","-a","-m","\"add submod\"") + test_dir2 = tmp_path / "testrepo2" + gitp.git_operation("clone",test_dir,test_dir2) + return test_dir2 + + +@pytest.fixture +def complex_repo(tmp_path, logger): + test_dir = tmp_path / "testcomplex" + test_dir.mkdir() + str_path = str(test_dir) + gitp = GitInterface(str_path, logger) + gitp.git_operation("remote", "add", "origin", "https://github.com/jedwards4b/fleximod-test2") + gitp.git_operation("fetch", "origin") + gitp.git_operation("checkout", "v0.0.1") + return test_dir + +@pytest.fixture +def complex_update(tmp_path, logger): + test_dir = tmp_path / "testcomplex" + test_dir.mkdir() + str_path = str(test_dir) + gitp = GitInterface(str_path, logger) + gitp.git_operation("remote", "add", "origin", "https://github.com/jedwards4b/fleximod-test2") + gitp.git_operation("fetch", "origin") + gitp.git_operation("checkout", "v0.0.2") + + return test_dir + +@pytest.fixture +def git_fleximod(): + def _run_fleximod(path, args, input=None): + cmd = ["git", "fleximod"] + args.split() + result = subprocess.run(cmd, cwd=path, input=input, + stdout=subprocess.PIPE, stderr=subprocess.PIPE, + text=True) + if result.returncode: + print(result.stdout) + print(result.stderr) + return result + return _run_fleximod + diff --git a/.lib/tests/test_a_import.py b/.lib/tests/test_a_import.py new file mode 100644 index 0000000000..d5ca878de5 --- /dev/null +++ b/.lib/tests/test_a_import.py @@ -0,0 +1,8 @@ +# pylint: disable=unused-import +from git_fleximod import cli +from git_fleximod import utils +from git_fleximod.gitinterface import GitInterface +from git_fleximod.gitmodules import GitModules + +def test_import(): + print("here") diff --git a/.lib/tests/test_b_update.py b/.lib/tests/test_b_update.py new file mode 100644 index 0000000000..159f1cfae0 --- /dev/null +++ b/.lib/tests/test_b_update.py @@ -0,0 +1,26 @@ +import pytest +from pathlib import Path + +def test_basic_checkout(git_fleximod, test_repo, shared_repos): + # Prepare a simple .gitmodules + gm = shared_repos['gitmodules_content'] + file_path = (test_repo / ".gitmodules") + repo_name = shared_repos["submodule_name"] + repo_path = shared_repos["subrepo_path"] + + file_path.write_text(gm) + + # Run the command + result = git_fleximod(test_repo, f"update {repo_name}") + + # Assertions + assert result.returncode == 0 + assert Path(test_repo / repo_path).exists() # Did the submodule directory get created? + if "sparse" in repo_name: + assert Path(test_repo / f"{repo_path}/m4").exists() # Did the submodule sparse directory get created? + assert not Path(test_repo / f"{repo_path}/README").exists() # Did only the submodule sparse directory get created? + + status = git_fleximod(test_repo, f"status {repo_name}") + + assert shared_repos["status2"] in status.stdout + diff --git a/.lib/tests/test_c_required.py b/.lib/tests/test_c_required.py new file mode 100644 index 0000000000..89ab8d294d --- /dev/null +++ b/.lib/tests/test_c_required.py @@ -0,0 +1,30 @@ +import pytest +from pathlib import Path + +def test_required(git_fleximod, test_repo, shared_repos): + file_path = (test_repo / ".gitmodules") + gm = shared_repos["gitmodules_content"] + repo_name = shared_repos["submodule_name"] + if file_path.exists(): + with file_path.open("r") as f: + gitmodules_content = f.read() + # add the entry if it does not exist + if repo_name not in gitmodules_content: + file_path.write_text(gitmodules_content+gm) + # or if it is incomplete + elif gm not in gitmodules_content: + file_path.write_text(gm) + else: + file_path.write_text(gm) + result = git_fleximod(test_repo, "update") + assert result.returncode == 0 + status = git_fleximod(test_repo, f"status {repo_name}") + assert shared_repos["status3"] in status.stdout + status = git_fleximod(test_repo, f"update --optional") + assert result.returncode == 0 + status = git_fleximod(test_repo, f"status {repo_name}") + assert shared_repos["status4"] in status.stdout + status = git_fleximod(test_repo, f"update {repo_name}") + assert result.returncode == 0 + status = git_fleximod(test_repo, f"status {repo_name}") + assert shared_repos["status4"] in status.stdout diff --git a/.lib/tests/test_d_complex.py b/.lib/tests/test_d_complex.py new file mode 100644 index 0000000000..edde7d816d --- /dev/null +++ b/.lib/tests/test_d_complex.py @@ -0,0 +1,66 @@ +import pytest +from pathlib import Path +from git_fleximod.gitinterface import GitInterface + +def test_complex_checkout(git_fleximod, complex_repo, logger): + status = git_fleximod(complex_repo, "status") + assert("ToplevelOptional not checked out, aligned at tag v5.3.2" in status.stdout) + assert("ToplevelRequired not checked out, aligned at tag MPIserial_2.5.0" in status.stdout) + assert("AlwaysRequired not checked out, aligned at tag MPIserial_2.4.0" in status.stdout) + assert("Complex not checked out, aligned at tag testtag02" in status.stdout) + assert("AlwaysOptional not checked out, out of sync at tag None, expected tag is MPIserial_2.3.0" in status.stdout) + + # This should checkout and update test_submodule and complex_sub + result = git_fleximod(complex_repo, "update") + assert result.returncode == 0 + + status = git_fleximod(complex_repo, "status") + assert("ToplevelOptional not checked out, aligned at tag v5.3.2" in status.stdout) + assert("ToplevelRequired at tag MPIserial_2.5.0" in status.stdout) + assert("AlwaysRequired at tag MPIserial_2.4.0" in status.stdout) + assert("Complex at tag testtag02" in status.stdout) + + # now check the complex_sub + root = (complex_repo / "modules" / "complex") + assert(not (root / "libraries" / "gptl" / ".git").exists()) + assert(not (root / "libraries" / "mpi-serial" / ".git").exists()) + assert((root / "modules" / "mpi-serial" / ".git").exists()) + assert(not (root / "modules" / "mpi-serial2" / ".git").exists()) + assert((root / "modules" / "mpi-sparse" / ".git").exists()) + assert((root / "modules" / "mpi-sparse" / "m4").exists()) + assert(not (root / "modules" / "mpi-sparse" / "README").exists()) + + # update a single optional submodule + + result = git_fleximod(complex_repo, "update ToplevelOptional") + assert result.returncode == 0 + + status = git_fleximod(complex_repo, "status") + assert("ToplevelOptional at tag v5.3.2" in status.stdout) + assert("ToplevelRequired at tag MPIserial_2.5.0" in status.stdout) + assert("AlwaysRequired at tag MPIserial_2.4.0" in status.stdout) + assert("Complex at tag testtag02" in status.stdout) + assert("AlwaysOptional not checked out, out of sync at tag None, expected tag is MPIserial_2.3.0" in status.stdout) + + # Finally update optional + result = git_fleximod(complex_repo, "update --optional") + assert result.returncode == 0 + + status = git_fleximod(complex_repo, "status") + assert("ToplevelOptional at tag v5.3.2" in status.stdout) + assert("ToplevelRequired at tag MPIserial_2.5.0" in status.stdout) + assert("AlwaysRequired at tag MPIserial_2.4.0" in status.stdout) + assert("Complex at tag testtag02" in status.stdout) + assert("AlwaysOptional at tag MPIserial_2.3.0" in status.stdout) + + # now check the complex_sub + root = (complex_repo / "modules" / "complex" ) + assert(not (root / "libraries" / "gptl" / ".git").exists()) + assert(not (root / "libraries" / "mpi-serial" / ".git").exists()) + assert((root / "modules" / "mpi-serial" / ".git").exists()) + assert((root / "modules" / "mpi-serial2" / ".git").exists()) + assert((root / "modules" / "mpi-sparse" / ".git").exists()) + assert((root / "modules" / "mpi-sparse" / "m4").exists()) + assert(not (root / "modules" / "mpi-sparse" / "README").exists()) + + diff --git a/.lib/tests/test_e_complex_update.py b/.lib/tests/test_e_complex_update.py new file mode 100644 index 0000000000..0c3ab4c6a6 --- /dev/null +++ b/.lib/tests/test_e_complex_update.py @@ -0,0 +1,69 @@ +import pytest +from pathlib import Path +from git_fleximod.gitinterface import GitInterface + +def test_complex_update(git_fleximod, complex_update, logger): + status = git_fleximod(complex_update, "status") + assert("ToplevelOptional not checked out, aligned at tag v5.3.2" in status.stdout) + assert("ToplevelRequired not checked out, aligned at tag MPIserial_2.5.0" in status.stdout) + assert("AlwaysRequired not checked out, aligned at tag MPIserial_2.4.0" in status.stdout) + assert("Complex not checked out, out of sync at tag testtag02, expected tag is testtag3" in status.stdout) + assert("AlwaysOptional not checked out, out of sync at tag None, expected tag is MPIserial_2.3.0" in status.stdout) + + # This should checkout and update test_submodule and complex_sub + result = git_fleximod(complex_update, "update") + assert result.returncode == 0 + + status = git_fleximod(complex_update, "status") + assert("ToplevelOptional not checked out, aligned at tag v5.3.2" in status.stdout) + assert("ToplevelRequired at tag MPIserial_2.5.0" in status.stdout) + assert("AlwaysRequired at tag MPIserial_2.4.0" in status.stdout) + assert("Complex at tag testtag3" in status.stdout) + + # now check the complex_sub + root = (complex_update / "modules" / "complex") + assert(not (root / "libraries" / "gptl" / ".git").exists()) + assert(not (root / "libraries" / "mpi-serial" / ".git").exists()) + assert((root / "modules" / "mpi-serialAR" / ".git").exists()) + assert((root / "modules" / "mpi-serialSAR" / ".git").exists()) + assert(not (root / "modules" / "mpi-serial2" / ".git").exists()) + assert((root / "modules" / "mpi-sparse" / ".git").exists()) + assert((root / "modules" / "mpi-sparse" / "m4").exists()) + assert(not (root / "modules" / "mpi-sparse" / "README").exists()) + + # update a single optional submodule + + result = git_fleximod(complex_update, "update ToplevelOptional") + assert result.returncode == 0 + + status = git_fleximod(complex_update, "status") + assert("ToplevelOptional at tag v5.3.2" in status.stdout) + assert("ToplevelRequired at tag MPIserial_2.5.0" in status.stdout) + assert("AlwaysRequired at tag MPIserial_2.4.0" in status.stdout) + assert("Complex at tag testtag3" in status.stdout) + assert("AlwaysOptional not checked out, out of sync at tag None, expected tag is MPIserial_2.3.0" in status.stdout) + + # Finally update optional + result = git_fleximod(complex_update, "update --optional") + assert result.returncode == 0 + + status = git_fleximod(complex_update, "status") + assert("ToplevelOptional at tag v5.3.2" in status.stdout) + assert("ToplevelRequired at tag MPIserial_2.5.0" in status.stdout) + assert("AlwaysRequired at tag MPIserial_2.4.0" in status.stdout) + assert("Complex at tag testtag3" in status.stdout) + assert("AlwaysOptional at tag MPIserial_2.3.0" in status.stdout) + + # now check the complex_sub + root = (complex_update / "modules" / "complex" ) + assert(not (root / "libraries" / "gptl" / ".git").exists()) + assert(not (root / "libraries" / "mpi-serial" / ".git").exists()) + assert(not (root / "modules" / "mpi-serial" / ".git").exists()) + assert((root / "modules" / "mpi-serialAR" / ".git").exists()) + assert((root / "modules" / "mpi-serialSAR" / ".git").exists()) + assert((root / "modules" / "mpi-sparse" / ".git").exists()) + assert((root / "modules" / "mpi-serial2" / ".git").exists()) + assert((root / "modules" / "mpi-sparse" / "m4").exists()) + assert(not (root / "modules" / "mpi-sparse" / "README").exists()) + +