CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
rrtmgp_lw_main.F90
1
5 use mpi_f08
6 use machine, only: kind_phys, kind_dbl_prec
7 use mo_optical_props, only: ty_optical_props_1scl, ty_optical_props_2str
8 use mo_cloud_optics, only: ty_cloud_optics
9 use mo_rte_lw, only: rte_lw
10 use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp
11 use mo_gas_concentrations, only: ty_gas_concs
12 use mo_fluxes_byband, only: ty_fluxes_byband
13 use mo_source_functions, only: ty_source_func_lw
14 use radiation_tools, only: check_error_msg
15 use rrtmgp_lw_gas_optics, only: lw_gas_props,rrtmgp_lw_gas_optics_init
16 use rrtmgp_lw_cloud_optics, only: lw_cloud_props, rrtmgp_lw_cloud_optics_init, abssnow0, &
17 abssnow1, absrain
18 use gfs_rrtmgp_pre, only: istr_h2o, istr_co2, istr_o3, istr_n2o, istr_ch4, &
19 istr_o2, istr_ccl4, istr_cfc11, istr_cfc12, istr_cfc22, &
20 eps, oneminus, ftiny
22 use rrtmgp_sampling, only: sampled_mask, draw_samples
23 implicit none
24
25 public rrtmgp_lw_main_init, rrtmgp_lw_main_run
26contains
27
31 subroutine rrtmgp_lw_main_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, rrtmgp_lw_file_clouds,&
32 active_gases_array, doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_sgs_pbl, &
33 doGP_sgs_cnv, nrghice, mpicomm, mpirank, mpiroot, nLay, rrtmgp_phys_blksz, &
34 errmsg, errflg)
35
36 ! Inputs
37 character(len=128),intent(in) :: &
38 rrtmgp_root_dir, & !< RTE-RRTMGP root directory
39 rrtmgp_lw_file_clouds, & !< RRTMGP file containing coefficients used to compute
40
41 rrtmgp_lw_file_gas
43 character(len=*), dimension(:), intent(in), optional :: &
44 active_gases_array
45 logical, intent(in) :: &
46 dogp_cldoptics_pade, & !< Use RRTMGP cloud-optics: PADE approximation?
47 dogp_cldoptics_lut, & !< Use RRTMGP cloud-optics: LUTs?
48 dogp_sgs_pbl, & !< Flag to include sgs PBL clouds
49 dogp_sgs_cnv
50 integer, intent(inout) :: &
51 nrghice
52 type(mpi_comm),intent(in) :: &
53 mpicomm
54 integer,intent(in) :: &
55 mpirank, & !< Current MPI rank
56 mpiroot, & !< Master MPI rank
57 rrtmgp_phys_blksz, & !< Number of horizontal points to process at once.
58 nlay
59
60 ! Outputs
61 character(len=*), intent(out) :: &
62 errmsg
63 integer, intent(out) :: &
64 errflg
65
66 ! Initialize CCPP error handling variables
67 errmsg = ''
68 errflg = 0
69
70 ! RRTMGP longwave gas-optics (k-distribution) initialization
71 call rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, &
72 active_gases_array, mpicomm, mpirank, mpiroot, errmsg, errflg)
73
74 ! RRTMGP longwave cloud-optics initialization
75 call rrtmgp_lw_cloud_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_clouds, &
76 dogp_cldoptics_pade, dogp_cldoptics_lut, nrghice, mpicomm, mpirank, mpiroot, &
77 errmsg, errflg)
78
79 end subroutine rrtmgp_lw_main_init
80
84 subroutine rrtmgp_lw_main_run(doLWrad, doLWclrsky, top_at_1, doGP_lwscat, &
85 use_LW_jacobian, doGP_sgs_cnv, doGP_sgs_pbl, nCol, nLay, nGases,rrtmgp_phys_blksz,&
86 nGauss_angles, icseed_lw, iovr, iovr_convcld, iovr_max, iovr_maxrand, iovr_rand, &
87 iovr_dcorr, iovr_exp, iovr_exprand, isubc_lw, semis, tsfg, p_lay, p_lev, t_lay, &
88 t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2, &
89 cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, &
90 cld_rwp, cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, &
91 cld_cnv_reice, cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, &
92 cloud_overlap_param, active_gases_array, aerlw_tau, aerlw_ssa, aerlw_g, &
93 fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, fluxlwDOWN_clrsky, &
94 fluxlwUP_jac, fluxlwUP_radtime, fluxlwDOWN_radtime, errmsg, errflg)
95
96 ! Inputs
97 logical, intent(in) :: &
98 dolwrad, & ! Flag to perform longwave calculation
99 dolwclrsky, & ! Flag to compute clear-sky fluxes
100 top_at_1, & ! Flag for vertical ordering convention
101 use_lw_jacobian, & ! Flag to compute Jacobian of longwave surface flux
102 dogp_sgs_pbl, & ! Flag to include sgs PBL clouds
103 dogp_sgs_cnv, & ! Flag to include sgs convective clouds
104 dogp_lwscat ! Flag to include scattering in clouds
105 integer,intent(in) :: &
106 ncol, & ! Number of horizontal points
107 nlay, & ! Number of vertical grid points.
108 ngases, & ! Number of active gases
109 rrtmgp_phys_blksz, & ! Number of horizontal points to process at once.
110 ngauss_angles, & ! Number of gaussian quadrature angles used
111 iovr, & ! Choice of cloud-overlap method
112 iovr_convcld, & ! Choice of convective cloud-overlap
113 iovr_max, & ! Flag for maximum cloud overlap method
114 iovr_maxrand, & ! Flag for maximum-random cloud overlap method
115 iovr_rand, & ! Flag for random cloud overlap method
116 iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method
117 iovr_exp, & ! Flag for exponential cloud overlap method
118 iovr_exprand, & ! Flag for exponential-random cloud overlap method
119 isubc_lw ! Flag for cloud-seeding (rng) for cloud-sampling
120 integer,intent(in),dimension(:), optional :: &
121 icseed_lw ! Seed for random number generation for longwave radiation
122 real(kind_phys), dimension(:), intent(in) :: &
123 semis, & ! Surface-emissivity (1)
124 tsfg ! Skin temperature (K)
125 real(kind_phys), dimension(:,:), intent(in), optional :: &
126 p_lay, & ! Pressure @ model layer-centers (Pa)
127 t_lay, & ! Temperature (K)
128 p_lev, & ! Pressure @ model layer-interfaces (Pa)
129 t_lev, & ! Temperature @ model levels (K)
130 vmr_o2, & ! Molar-mixing ratio oxygen
131 vmr_h2o, & ! Molar-mixing ratio water vapor
132 vmr_o3, & ! Molar-mixing ratio ozone
133 vmr_ch4, & ! Molar-mixing ratio methane
134 vmr_n2o, & ! Molar-mixing ratio nitrous oxide
135 vmr_co2 ! Molar-mixing ratio carbon dioxide
136 real(kind_phys), dimension(:,:), intent(in) :: &
137 cld_frac, & ! Cloud-fraction for stratiform clouds
138 cld_lwp, & ! Water path for stratiform liquid cloud-particles
139 cld_reliq, & ! Effective radius for stratiform liquid cloud-particles
140 cld_iwp, & ! Water path for stratiform ice cloud-particles
141 cld_reice, & ! Effective radius for stratiform ice cloud-particles
142 cld_swp, & ! Water path for snow hydrometeors
143 cld_resnow, & ! Effective radius for snow hydrometeors
144 cld_rwp, & ! Water path for rain hydrometeors
145 cld_rerain ! Effective radius for rain hydrometeors
146 real(kind_phys), dimension(:,:), intent(in), optional :: &
147 precip_frac, & ! Precipitation fraction (not active, currently precipitation optics uses cloud-fraction)
148 cld_cnv_lwp, & ! Water path for convective liquid cloud-particles
149 cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles
150 cld_cnv_iwp, & ! Water path for convective ice cloud-particles
151 cld_cnv_reice, & ! Effective radius for convective ice cloud-particles
152 cld_pbl_lwp, & ! Water path for PBL liquid cloud-particles
153 cld_pbl_reliq, & ! Effective radius for PBL liquid cloud-particles
154 cld_pbl_iwp, & ! Water path for PBL ice cloud-particles
155 cld_pbl_reice, & ! Effective radius for PBL ice cloud-particles
156 cloud_overlap_param ! Cloud overlap parameter
157 real(kind_phys), dimension(:,:,:), intent(in) :: &
158 aerlw_tau, & ! Aerosol optical depth
159 aerlw_ssa, & ! Aerosol single scattering albedo
160 aerlw_g ! Aerosol asymmetry paramter
161 character(len=*), dimension(:), intent(in), optional :: &
162 active_gases_array ! List of active gases from namelist as array
163
164 ! Outputs
165 real(kind_phys), dimension(:,:), intent(inout), optional :: &
166 fluxlwup_jac, & ! Jacobian of upwelling LW surface radiation (W/m2/K)
167 fluxlwup_allsky, & ! All-sky flux (W/m2)
168 fluxlwdown_allsky, & ! All-sky flux (W/m2)
169 fluxlwup_clrsky, & ! Clear-sky flux (W/m2)
170 fluxlwdown_clrsky, & ! All-sky flux (W/m2)
171 fluxlwup_radtime, & ! Copy of fluxes (Used for coupling)
172 fluxlwdown_radtime !
173 character(len=*), intent(out) :: &
174 errmsg ! CCPP error message
175 integer, intent(out) :: &
176 errflg ! CCPP error flag
177
178 ! Local variables
179 type(ty_fluxes_byband) :: flux_allsky, flux_clrsky
180 integer :: icol, ilay, igas, iband, icol2, ix, iblck
181 integer, dimension(rrtmgp_phys_blksz) :: ipseed_lw
182 type(random_stat) :: rng_stat
183 real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1
184 logical, dimension(rrtmgp_phys_blksz,nLay,lw_gas_props%get_ngpt()) :: maskmcica
185 real(kind_phys), dimension(rrtmgp_phys_blksz) :: tau_rain, tau_snow
186 real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt()) :: rng1d
187 real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3d,rng3d2
188 real(kind_dbl_prec), dimension(lw_gas_props%get_ngpt()*nLay) :: rng2d
189 real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,lw_gas_props%get_nband()),target :: &
190 fluxlw_up_allsky, fluxlw_up_clrsky, fluxlw_dn_allsky, fluxlw_dn_clrsky
191 real(kind_phys), dimension(rrtmgp_phys_blksz,lw_gas_props%get_ngpt()) :: lw_ds
192 real(kind_phys), dimension(lw_gas_props%get_nband(),rrtmgp_phys_blksz) :: sfc_emiss_byband
193
194 ! Local RRTMGP DDTs.
195 type(ty_gas_concs) :: gas_concs
196 type(ty_optical_props_1scl) :: lw_optical_props_clrsky, lw_optical_props_aerosol_local
197 type(ty_optical_props_2str) :: lw_optical_props_clouds, lw_optical_props_cloudsbyband, &
198 lw_optical_props_cnvcloudsbyband, lw_optical_props_pblcloudsbyband, &
199 lw_optical_props_precipbyband
200 type(ty_source_func_lw) :: sources
201
202 ! Initialize CCPP error handling variables
203 errmsg = ''
204 errflg = 0
205
206 if (.not. dolwrad) return
207
208 !
209 ! Initialize RRTMGP DDTs (local)
210 !
211
212 ! ty_gas_concs
213 call check_error_msg('rrtmgp_lw_main_gas_concs_run',gas_concs%init(active_gases_array))
214
215 ! ty_optical_props
216 call check_error_msg('rrtmgp_lw_main_gas_optics_run',&
217 lw_optical_props_clrsky%alloc_1scl(rrtmgp_phys_blksz, nlay, lw_gas_props))
218 call check_error_msg('rrtmgp_lw_main_sources_run',&
219 sources%alloc(rrtmgp_phys_blksz, nlay, lw_gas_props))
220 call check_error_msg('rrtmgp_lw_main_cloud_optics_run',&
221 lw_optical_props_cloudsbyband%alloc_2str(rrtmgp_phys_blksz, nlay, lw_gas_props%get_band_lims_wavenumber()))
222 call check_error_msg('rrtmgp_lw_main_precip_optics_run',&
223 lw_optical_props_precipbyband%alloc_2str(rrtmgp_phys_blksz, nlay, lw_gas_props%get_band_lims_wavenumber()))
224 call check_error_msg('rrtmgp_lw_mian_cloud_sampling_run', &
225 lw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nlay, lw_gas_props))
226 call check_error_msg('rrtmgp_lw_main_aerosol_optics_run',&
227 lw_optical_props_aerosol_local%alloc_1scl(rrtmgp_phys_blksz, nlay, lw_gas_props%get_band_lims_wavenumber()))
228 if (dogp_sgs_cnv) then
229 call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics_run',&
230 lw_optical_props_cnvcloudsbyband%alloc_2str(rrtmgp_phys_blksz, nlay, lw_gas_props%get_band_lims_wavenumber()))
231 endif
232 if (dogp_sgs_pbl) then
233 call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics_run',&
234 lw_optical_props_pblcloudsbyband%alloc_2str(rrtmgp_phys_blksz, nlay, lw_gas_props%get_band_lims_wavenumber()))
235 endif
236
237 ! ######################################################################################
238 !
239 ! Loop over all columns...
240 !
241 ! ######################################################################################
242 do icol=1,ncol,rrtmgp_phys_blksz
243 icol2 = icol + rrtmgp_phys_blksz - 1
244
245 ! Initialize/reset
246
247 ! ty_optical_props
248 lw_optical_props_clrsky%tau = 0._kind_phys
249 lw_optical_props_precipbyband%tau = 0._kind_phys
250 lw_optical_props_precipbyband%ssa = 0._kind_phys
251 lw_optical_props_precipbyband%g = 0._kind_phys
252 lw_optical_props_cloudsbyband%tau = 0._kind_phys
253 lw_optical_props_cloudsbyband%ssa = 0._kind_phys
254 lw_optical_props_cloudsbyband%g = 0._kind_phys
255 lw_optical_props_clouds%tau = 0._kind_phys
256 lw_optical_props_clouds%ssa = 0._kind_phys
257 lw_optical_props_clouds%g = 0._kind_phys
258 sources%sfc_source = 0._kind_phys
259 sources%lay_source = 0._kind_phys
260 sources%lev_source_inc = 0._kind_phys
261 sources%lev_source_dec = 0._kind_phys
262 sources%sfc_source_Jac = 0._kind_phys
263 fluxlw_up_allsky = 0._kind_phys
264 fluxlw_dn_allsky = 0._kind_phys
265 fluxlw_up_clrsky = 0._kind_phys
266 fluxlw_dn_clrsky = 0._kind_phys
267 if (dogp_sgs_cnv) lw_optical_props_cnvcloudsbyband%tau = 0._kind_phys
268 if (dogp_sgs_pbl) lw_optical_props_pblcloudsbyband%tau = 0._kind_phys
269
270 ! ty_fluxes_byband
271 fluxlw_up_allsky = 0._kind_phys
272 fluxlw_dn_allsky = 0._kind_phys
273 fluxlw_up_clrsky = 0._kind_phys
274 fluxlw_dn_clrsky = 0._kind_phys
275 flux_allsky%bnd_flux_up => fluxlw_up_allsky
276 flux_allsky%bnd_flux_dn => fluxlw_dn_allsky
277 flux_clrsky%bnd_flux_up => fluxlw_up_clrsky
278 flux_clrsky%bnd_flux_dn => fluxlw_dn_clrsky
279
280 ! ###################################################################################
281 !
282 ! Set gas-concentrations
283 !
284 ! ###################################################################################
285 call check_error_msg('rrtmgp_lw_main_set_vmr_o2', &
286 gas_concs%set_vmr(trim(active_gases_array(istr_o2)), vmr_o2(icol:icol2,:)))
287 call check_error_msg('rrtmgp_lw_main_set_vmr_co2', &
288 gas_concs%set_vmr(trim(active_gases_array(istr_co2)),vmr_co2(icol:icol2,:)))
289 call check_error_msg('rrtmgp_lw_main_set_vmr_ch4', &
290 gas_concs%set_vmr(trim(active_gases_array(istr_ch4)),vmr_ch4(icol:icol2,:)))
291 call check_error_msg('rrtmgp_lw_main_set_vmr_n2o', &
292 gas_concs%set_vmr(trim(active_gases_array(istr_n2o)),vmr_n2o(icol:icol2,:)))
293 call check_error_msg('rrtmgp_lw_main_set_vmr_h2o', &
294 gas_concs%set_vmr(trim(active_gases_array(istr_h2o)),vmr_h2o(icol:icol2,:)))
295 call check_error_msg('rrtmgp_lw_main_set_vmr_o3', &
296 gas_concs%set_vmr(trim(active_gases_array(istr_o3)), vmr_o3(icol:icol2,:)))
297
298 ! ###################################################################################
299 !
300 ! Surface emissity in each band
301 !
302 ! ###################################################################################
303 ! Assign same emissivity to all band
304 do iblck=1,rrtmgp_phys_blksz
305 if (semis(icol+iblck-1) > eps .and. semis(icol+iblck-1) <= 1._kind_phys) then
306 do iband=1,lw_gas_props%get_nband()
307 sfc_emiss_byband(iband,iblck) = semis(icol+iblck-1)
308 enddo
309 else
310 sfc_emiss_byband(1:lw_gas_props%get_nband(),iblck) = 1.0
311 endif
312 enddo
313
314 ! ###################################################################################
315 !
316 ! Compute gas-optics...
317 !
318 ! ###################################################################################
319 call check_error_msg('rrtmgp_lw_main_gas_optics',lw_gas_props%gas_optics(&
320 p_lay(icol:icol2,:), & ! IN - Pressure @ layer-centers (Pa)
321 p_lev(icol:icol2,:), & ! IN - Pressure @ layer-interfaces (Pa)
322 t_lay(icol:icol2,:), & ! IN - Temperature @ layer-centers (K)
323 tsfg(icol:icol2), & ! IN - Skin-temperature (K)
324 gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios
325 lw_optical_props_clrsky, & ! OUT - RRTMGP DDT: longwave optical properties
326 sources, & ! OUT - RRTMGP DDT: source functions
327 tlev=t_lev(icol:icol2,:))) ! IN - Temperature @ layer-interfaces (K) (optional)
328
329 ! ###################################################################################
330 !
331 ! Compute cloud-optics...
332 !
333 ! ###################################################################################
334 ! Create clear/cloudy indicator
335 zcf0(:) = 1._kind_phys
336 zcf1(:) = 1._kind_phys
337 do iblck = 1, rrtmgp_phys_blksz
338 do ilay=1,nlay
339 zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(icol+iblck-1,ilay))
340 enddo
341 if (zcf0(iblck) <= ftiny) zcf0(iblck) = 0._kind_phys
342 if (zcf0(iblck) > oneminus) zcf0(iblck) = 1._kind_phys
343 zcf1(iblck) = 1._kind_phys - zcf0(iblck)
344 enddo
345
346 if (any(zcf1 .gt. eps)) then
347 ! Microphysical (gridmean) cloud optics
348 call check_error_msg('rrtmgp_lw_main_cloud_optics',lw_cloud_props%cloud_optics(&
349 cld_lwp(icol:icol2,:), & ! IN - Cloud liquid water path (g/m2)
350 cld_iwp(icol:icol2,:), & ! IN - Cloud ice water path (g/m2)
351 cld_reliq(icol:icol2,:), & ! IN - Cloud liquid effective radius (microns)
352 cld_reice(icol:icol2,:), & ! IN - Cloud ice effective radius (microns)
353 lw_optical_props_cloudsbyband)) ! OUT - RRTMGP DDT containing cloud radiative properties
354 ! in each band
355 ! Include convective (subgrid scale) clouds?
356 if (dogp_sgs_cnv) then
357 ! Compute
358 call check_error_msg('rrtmgp_lw_main_cnv_cloud_optics',lw_cloud_props%cloud_optics(&
359 cld_cnv_lwp(icol:icol2,:), & ! IN - Convective cloud liquid water path (g/m2)
360 cld_cnv_iwp(icol:icol2,:), & ! IN - Convective cloud ice water path (g/m2)
361 cld_cnv_reliq(icol:icol2,:), & ! IN - Convective cloud liquid effective radius (microns)
362 cld_cnv_reice(icol:icol2,:), & ! IN - Convective cloud ice effective radius (microns)
363 lw_optical_props_cnvcloudsbyband)) ! OUT - RRTMGP DDT containing convective cloud radiative properties
364 ! in each band
365 ! Increment
366 call check_error_msg('rrtmgp_lw_main_increment_cnvclouds_to_clouds',&
367 lw_optical_props_cnvcloudsbyband%increment(lw_optical_props_cloudsbyband))
368 endif
369
370 ! Include PBL (subgrid scale) clouds?
371 if (dogp_sgs_pbl) then
372 ! Compute
373 call check_error_msg('rrtmgp_lw_main_pbl_cloud_optics',lw_cloud_props%cloud_optics(&
374 cld_pbl_lwp(icol:icol2,:), & ! IN - PBL cloud liquid water path (g/m2)
375 cld_pbl_iwp(icol:icol2,:), & ! IN - PBL cloud ice water path (g/m2)
376 cld_pbl_reliq(icol:icol2,:), & ! IN - PBL cloud liquid effective radius (microns)
377 cld_pbl_reice(icol:icol2,:), & ! IN - PBL cloud ice effective radius (microns)
378 lw_optical_props_pblcloudsbyband)) ! OUT - RRTMGP DDT containing PBL cloud radiative properties
379 ! in each band
380 ! Increment
381 call check_error_msg('rrtmgp_lw_main_increment_pblclouds_to_clouds',&
382 lw_optical_props_pblcloudsbyband%increment(lw_optical_props_cloudsbyband))
383 endif
384 endif
385
386 ! ###################################################################################
387 !
388 ! Cloud precipitation optics: rain and snow(+groupel)
389 !
390 ! ###################################################################################
391 tau_rain(:) = 0._kind_phys
392 tau_snow(:) = 0._kind_phys
393 do ix=1,rrtmgp_phys_blksz
394 do ilay=1,nlay
395 if (cld_frac(icol+ix-1,ilay) .gt. eps) then
396 ! Rain optical-depth (No band dependence)
397 tau_rain(ix) = absrain*cld_rwp(icol+ix-1,ilay)
398
399 ! Snow (+groupel) optical-depth (No band dependence)
400 if (cld_swp(icol+ix-1,ilay) .gt. 0. .and. cld_resnow(icol+ix-1,ilay) .gt. 10._kind_phys) then
401 tau_snow(ix) = abssnow0*1.05756*cld_swp(icol+ix-1,ilay)/cld_resnow(icol+ix-1,ilay)
402 else
403 tau_snow(ix) = 0.0
404 endif
405 do iband=1,lw_gas_props%get_nband()
406 lw_optical_props_precipbyband%tau(ix,ilay,iband) = tau_rain(ix) + tau_snow(ix)
407 enddo
408 endif
409 enddo
410 enddo
411 ! Increment
412 call check_error_msg('rrtmgp_lw_main_increment_precip_to_clouds',&
413 lw_optical_props_precipbyband%increment(lw_optical_props_cloudsbyband))
414
415 ! ###################################################################################
416 !
417 ! Cloud-sampling
418 ! *Note* All of the included cloud-types are sampled together, not independently.
419 !
420 ! ###################################################################################
421 if (any(zcf1 .gt. eps)) then
422 ! Change random number seed value for each radiation invocation (isubc_lw =1 or 2).
423 if(isubc_lw == 1) then ! advance prescribed permutation seed
424 do ix=1,rrtmgp_phys_blksz
425 ipseed_lw(ix) = lw_gas_props%get_ngpt() + icol + ix - 1
426 enddo
427 elseif (isubc_lw == 2) then ! use input array of permutaion seeds
428 do ix=1,rrtmgp_phys_blksz
429 ipseed_lw(ix) = icseed_lw(icol+ix-1)
430 enddo
431 endif
432
433 ! Call RNG
434 do ix=1,rrtmgp_phys_blksz
435 call random_setseed(ipseed_lw(ix),rng_stat)
436 ! Use same rng for each layer
437 if (iovr == iovr_max) then
438 call random_number(rng1d,rng_stat)
439 do ilay=1,nlay
440 rng3d(:,ilay,ix) = rng1d
441 enddo
442 else
443 do ilay=1,nlay
444 call random_number(rng1d,rng_stat)
445 rng3d(:,ilay,ix) = rng1d
446 enddo
447 endif
448 enddo
449
450 ! Cloud-overlap.
451 ! Maximum-random, random or maximum.
452 if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then
453 call sampled_mask(real(rng3d,kind=kind_phys), cld_frac(icol:icol2,:), maskmcica)
454 endif
455 ! Exponential decorrelation length overlap
456 if (iovr == iovr_dcorr) then
457 do ix=1,rrtmgp_phys_blksz
458 ! Generate second RNG
459 call random_setseed(ipseed_lw(ix),rng_stat)
460 call random_number(rng2d,rng_stat)
461 rng3d2(:,:,ix) = reshape(source = rng2d,shape=[lw_gas_props%get_ngpt(),nlay])
462 enddo
463 !
464 call sampled_mask(real(rng3d,kind=kind_phys), cld_frac(icol:icol2,:), maskmcica, &
465 overlap_param = cloud_overlap_param(icol:icol2,1:nlay-1), randoms2 = real(rng3d2, kind=kind_phys))
466 endif
467 ! Exponential or Exponential-random
468 if (iovr == iovr_exp .or. iovr == iovr_exprand) then
469 call sampled_mask(real(rng3d,kind=kind_phys), cld_frac(icol:icol2,:), maskmcica, &
470 overlap_param = cloud_overlap_param(icol:icol2,1:nlay-1))
471 endif
472 ! Sampling. Map band optical depth to each g-point using McICA
473 call check_error_msg('rrtmgp_lw_main_cloud_sampling',&
474 draw_samples(maskmcica, .true., &
475 lw_optical_props_cloudsbyband, lw_optical_props_clouds))
476 endif
477
478 ! ###################################################################################
479 !
480 ! Compute clear-sky fluxes (gaseous+aerosol) (optional)
481 !
482 ! ###################################################################################
483 ! Increment
484 lw_optical_props_aerosol_local%tau = aerlw_tau(icol:icol2,:,:)
485 call check_error_msg('rrtmgp_lw_main_increment_aerosol_to_clrsky',&
486 lw_optical_props_aerosol_local%increment(lw_optical_props_clrsky))
487
488 ! Call RTE solver
489 if (dolwclrsky) then
490 call check_error_msg('rrtmgp_lw_main_opt_angle',&
491 lw_gas_props%compute_optimal_angles(lw_optical_props_clrsky,lw_ds))
492 if (ngauss_angles .gt. 1) then
493 call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( &
494 lw_optical_props_clrsky, & ! IN - optical-properties
495 top_at_1, & ! IN - veritcal ordering flag
496 sources, & ! IN - source function
497 sfc_emiss_byband, & ! IN - surface emissivity in each LW band
498 flux_clrsky, & ! OUT - Fluxes
499 n_gauss_angles = ngauss_angles)) ! IN - Number of angles in Gaussian quadrature
500 else
501 call check_error_msg('rrtmgp_lw_main_lw_rte_clrsky',rte_lw( &
502 lw_optical_props_clrsky, & ! IN - optical-properties
503 top_at_1, & ! IN - veritcal ordering flag
504 sources, & ! IN - source function
505 sfc_emiss_byband, & ! IN - surface emissivity in each LW band
506 flux_clrsky, & ! OUT - Fluxes
507 lw_ds = lw_ds))
508 endif
509
510 ! Store fluxes
511 fluxlwup_clrsky(icol:icol2,:) = sum(flux_clrsky%bnd_flux_up, dim=3)
512 fluxlwdown_clrsky(icol:icol2,:) = sum(flux_clrsky%bnd_flux_dn, dim=3)
513 else
514 fluxlwup_clrsky(icol:icol2,:) = 0.0
515 fluxlwdown_clrsky(icol:icol2,:) = 0.0
516 endif
517
518 ! ###################################################################################
519 !
520 ! All-sky fluxes (clear-sky + clouds + precipitation)
521 ! *Note* CCPP does not allow for polymorphic types, they are ambiguous to the CCPP
522 ! framework. rte-rrtmgp uses polymorphic types extensively, for example, querying the
523 ! type to determine physics configuration/pathway/etc...
524 !
525 ! The logic in the code below is to satisfy the polymorphishm in the rte-rrtmgp code.
526 ! The rte-rrtmgp "increment" procedures are utilized to provide the correct type to the
527 ! rte solver (rte_lw). Rte_lw quieries the type determine if scattering is to be
528 ! included in the calculation. The increment procedures are called so that the correct
529 ! optical properties are inherited. ugh...
530 !
531 ! ###################################################################################
532
533 ! Include LW cloud-scattering?
534 if (dogp_lwscat) then
535 ! Increment
536 call check_error_msg('rrtmgp_lw_main_increment_clrsky_to_clouds',&
537 lw_optical_props_clrsky%increment(lw_optical_props_clouds))
538
539 if (use_lw_jacobian) then
540 ! Compute LW Jacobians
541 call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( &
542 lw_optical_props_clouds, & ! IN - optical-properties
543 top_at_1, & ! IN - veritcal ordering flag
544 sources, & ! IN - source function
545 sfc_emiss_byband, & ! IN - surface emissivity in each LW band
546 flux_allsky, & ! OUT - Flxues
547 n_gauss_angles = ngauss_angles, & ! IN - Number of angles in Gaussian quadrature
548 flux_up_jac = fluxlwup_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K)
549 else
550 call check_error_msg('rrtmgp_lw_main_lw_rte_allsky',rte_lw( &
551 lw_optical_props_clouds, & ! IN - optical-properties
552 top_at_1, & ! IN - veritcal ordering flag
553 sources, & ! IN - source function
554 sfc_emiss_byband, & ! IN - surface emissivity in each LW band
555 flux_allsky, & ! OUT - Flxues
556 n_gauss_angles = ngauss_angles)) ! IN - Number of angles in Gaussian quadrature
557 end if
558 ! No scattering in LW clouds.
559 else
560 ! Increment
561 call check_error_msg('rrtmgp_lw_main_increment_clouds_to_clrsky', &
562 lw_optical_props_clouds%increment(lw_optical_props_clrsky))
563
564 if (use_lw_jacobian) then
565 ! Compute LW Jacobians
566 call check_error_msg('rrtmgp_lw_rte_run',rte_lw( &
567 lw_optical_props_clrsky, & ! IN - optical-properties
568 top_at_1, & ! IN - veritcal ordering flag
569 sources, & ! IN - source function
570 sfc_emiss_byband, & ! IN - surface emissivity in each LW band
571 flux_allsky, & ! OUT - Flxues
572 n_gauss_angles = ngauss_angles, & ! IN - Number of angles in Gaussian quadrature
573 flux_up_jac = fluxlwup_jac)) ! OUT - surface temperature flux (upward) Jacobian (W/m2/K)
574 else
575 call check_error_msg('rrtmgp_lw_rte_run',rte_lw( &
576 lw_optical_props_clrsky, & ! IN - optical-properties
577 top_at_1, & ! IN - veritcal ordering flag
578 sources, & ! IN - source function
579 sfc_emiss_byband, & ! IN - surface emissivity in each LW band
580 flux_allsky, & ! OUT - Flxues
581 n_gauss_angles = ngauss_angles)) ! IN - Number of angles in Gaussian quadrature
582 end if
583 endif
584
585 ! Store fluxes
586 fluxlwup_allsky(icol:icol2,:) = sum(flux_allsky%bnd_flux_up, dim=3)
587 fluxlwdown_allsky(icol:icol2,:) = sum(flux_allsky%bnd_flux_dn, dim=3)
588
589 ! Save fluxes for coupling
590 fluxlwup_radtime(icol:icol2,:) = fluxlwup_allsky(icol:icol2,:)
591 fluxlwdown_radtime(icol:icol2,:) = fluxlwdown_allsky(icol:icol2,:)
592
593 enddo
594
595 end subroutine rrtmgp_lw_main_run
596end module rrtmgp_lw_main
This module calculates random numbers using the Mersenne twister.