CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
rrtmgp_sw_main.F90
1
3
5module rrtmgp_sw_main
6 use mpi_f08
7 use machine, only: kind_phys, kind_dbl_prec
8 use mo_optical_props, only: ty_optical_props_2str
9 use mo_cloud_optics, only: ty_cloud_optics
10 use module_radsw_parameters, only: cmpfsw_type
11 use mo_rte_sw, only: rte_sw
12 use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp
13 use mo_gas_concentrations, only: ty_gas_concs
14 use mo_fluxes_byband, only: ty_fluxes_byband
15 use radiation_tools, only: check_error_msg
16 use rrtmgp_sw_gas_optics, only: sw_gas_props,rrtmgp_sw_gas_optics_init
17 use rrtmgp_sw_cloud_optics, only: sw_cloud_props, rrtmgp_sw_cloud_optics_init, a0r, a0s, &
18 a1s, b0r, b0s, b1s, c0r, c0s
19 use gfs_rrtmgp_pre, only: istr_h2o, istr_co2, istr_o3, istr_n2o, istr_ch4, &
20 istr_o2, istr_ccl4, istr_cfc11, istr_cfc12, istr_cfc22, &
21 eps, oneminus, ftiny
22 use mersenne_twister, only: random_setseed, random_number, random_stat
23 use rrtmgp_sampling, only: sampled_mask, draw_samples
24 implicit none
25
26 public rrtmgp_sw_main_init, rrtmgp_sw_main_run
27
28contains
29
33 subroutine rrtmgp_sw_main_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, rrtmgp_sw_file_clouds,&
34 active_gases_array, doGP_cldoptics_PADE, doGP_cldoptics_LUT, doGP_sgs_pbl, &
35 doGP_sgs_cnv, nrghice, mpicomm, mpirank, mpiroot, nLay, rrtmgp_phys_blksz, &
36 errmsg, errflg)
37
38 ! Inputs
39 character(len=128),intent(in) :: &
40 rrtmgp_root_dir, & !< RTE-RRTMGP root directory
41 rrtmgp_sw_file_clouds, & !< RRTMGP file containing K-distribution data
42 rrtmgp_sw_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 ! Outputs
60 character(len=*), intent(out) :: &
61 errmsg
62 integer, intent(out) :: &
63 errflg
64
65 ! Initialize CCPP error handling variables
66 errmsg = ''
67 errflg = 0
68
69 ! RRTMGP shortwave gas-optics (k-distribution) initialization
70 call rrtmgp_sw_gas_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_gas, active_gases_array,&
71 mpicomm, mpirank, mpiroot, errmsg, errflg)
72
73 ! RRTMGP shortwave cloud-optics initialization
74 call rrtmgp_sw_cloud_optics_init(rrtmgp_root_dir, rrtmgp_sw_file_clouds, &
75 dogp_cldoptics_pade, dogp_cldoptics_lut, nrghice, mpicomm, mpirank, mpiroot, &
76 errmsg, errflg)
77
78 end subroutine rrtmgp_sw_main_init
79
83 subroutine rrtmgp_sw_main_run(doSWrad, doSWclrsky, top_at_1, doGP_sgs_cnv, doGP_sgs_pbl, &
84 nCol, nDay, nLay, nGases, rrtmgp_phys_blksz, idx, icseed_sw, iovr, iovr_convcld, &
85 iovr_max, iovr_maxrand, iovr_rand, iovr_dcorr, iovr_exp, iovr_exprand, isubc_sw, &
86 iSFC, sfc_alb_nir_dir, sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, coszen,&
87 p_lay, p_lev, t_lay, t_lev, vmr_o2, vmr_h2o, vmr_o3, vmr_ch4, vmr_n2o, vmr_co2, &
88 cld_frac, cld_lwp, cld_reliq, cld_iwp, cld_reice, cld_swp, cld_resnow, cld_rwp, &
89 cld_rerain, precip_frac, cld_cnv_lwp, cld_cnv_reliq, cld_cnv_iwp, cld_cnv_reice, &
90 cld_pbl_lwp, cld_pbl_reliq, cld_pbl_iwp, cld_pbl_reice, cloud_overlap_param, &
91 active_gases_array, aersw_tau, aersw_ssa, aersw_g, solcon, scmpsw, &
92 fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky, fluxswDOWN_clrsky, cldtausw, &
93 errmsg, errflg)
94
95 ! Inputs
96 logical, intent(in) :: &
97 doswrad, & ! Flag to perform shortwave calculation
98 doswclrsky, & ! Flag to compute clear-sky fluxes
99 top_at_1, & ! Flag for vertical ordering convention
100 dogp_sgs_pbl, & ! Flag to include sgs PBL clouds
101 dogp_sgs_cnv ! Flag to include sgs convective clouds
102 integer,intent(in) :: &
103 ncol, & ! Number of horizontal points
104 nday, & ! Number of daytime points
105 nlay, & ! Number of vertical grid points.
106 ngases, & ! Number of active gases
107 rrtmgp_phys_blksz, & ! Number of horizontal points to process at once.
108 iovr, & ! Choice of cloud-overlap method
109 iovr_convcld, & ! Choice of convective cloud-overlap
110 iovr_max, & ! Flag for maximum cloud overlap method
111 iovr_maxrand, & ! Flag for maximum-random cloud overlap method
112 iovr_rand, & ! Flag for random cloud overlap method
113 iovr_dcorr, & ! Flag for decorrelation-length cloud overlap method
114 iovr_exp, & ! Flag for exponential cloud overlap method
115 iovr_exprand, & ! Flag for exponential-random cloud overlap method
116 isubc_sw, & !
117 isfc
118 integer,intent(in),dimension(:) :: &
119 idx ! Index array for daytime points
120 integer,intent(in),dimension(:), optional :: &
121 icseed_sw ! Seed for random number generation for shortwave radiation
122 real(kind_phys), dimension(:), intent(in) :: &
123 sfc_alb_nir_dir, & ! Surface albedo (direct)
124 sfc_alb_nir_dif, & ! Surface albedo (diffuse)
125 sfc_alb_uvvis_dir, & ! Surface albedo (direct)
126 sfc_alb_uvvis_dif, & ! Surface albedo (diffuse)
127 coszen ! Cosize of SZA
128 real(kind_phys), dimension(:,:), intent(in), optional :: &
129 p_lay, & ! Pressure @ model layer-centers (Pa)
130 t_lay, & ! Temperature (K)
131 p_lev, & ! Pressure @ model layer-interfaces (Pa)
132 t_lev, & ! Temperature @ model levels (K)
133 vmr_o2, & ! Molar-mixing ratio oxygen
134 vmr_h2o, & ! Molar-mixing ratio water vapor
135 vmr_o3, & ! Molar-mixing ratio ozone
136 vmr_ch4, & ! Molar-mixing ratio methane
137 vmr_n2o, & ! Molar-mixing ratio nitrous oxide
138 vmr_co2 ! Molar-mixing ratio carbon dioxide
139 real(kind_phys), dimension(:,:), intent(in) :: &
140 cld_frac, & ! Cloud-fraction for stratiform clouds
141 cld_lwp, & ! Water path for stratiform liquid cloud-particles
142 cld_reliq, & ! Effective radius for stratiform liquid cloud-particles
143 cld_iwp, & ! Water path for stratiform ice cloud-particles
144 cld_reice, & ! Effective radius for stratiform ice cloud-particles
145 cld_swp, & ! Water path for snow hydrometeors
146 cld_resnow, & ! Effective radius for snow hydrometeors
147 cld_rwp, & ! Water path for rain hydrometeors
148 cld_rerain ! Effective radius for rain hydrometeors
149 real(kind_phys), dimension(:,:), intent(in), optional :: &
150 precip_frac, & ! Precipitation fraction
151 cld_cnv_lwp, & ! Water path for convective liquid cloud-particles
152 cld_cnv_reliq, & ! Effective radius for convective liquid cloud-particles
153 cld_cnv_iwp, & ! Water path for convective ice cloud-particles
154 cld_cnv_reice, & ! Effective radius for convective ice cloud-particles
155 cld_pbl_lwp, & ! Water path for PBL liquid cloud-particles
156 cld_pbl_reliq, & ! Effective radius for PBL liquid cloud-particles
157 cld_pbl_iwp, & ! Water path for PBL ice cloud-particles
158 cld_pbl_reice, & ! Effective radius for PBL ice cloud-particles
159 cloud_overlap_param !
160 real(kind_phys), dimension(:,:,:), intent(in) :: &
161 aersw_tau, & ! Aerosol optical depth
162 aersw_ssa, & ! Aerosol single scattering albedo
163 aersw_g ! Aerosol asymmetry paramter
164 character(len=*), dimension(:), intent(in), optional :: &
165 active_gases_array ! List of active gases from namelist as array
166 real(kind_phys), intent(in) :: &
167 solcon ! Solar constant
168
169 ! Outputs
170 character(len=*), intent(out) :: &
171 errmsg ! CCPP error message
172 integer, intent(out) :: &
173 errflg ! CCPP error flag
174 real(kind_phys), dimension(:,:), intent(inout) :: &
175 cldtausw ! Approx 10.mu band layer cloud optical depth
176 real(kind_phys), dimension(:,:), intent(inout), optional :: &
177 fluxswup_allsky, & ! RRTMGP upward all-sky flux profiles (W/m2)
178 fluxswdown_allsky, & ! RRTMGP downward all-sky flux profiles (W/m2)
179 fluxswup_clrsky, & ! RRTMGP upward clear-sky flux profiles (W/m2)
180 fluxswdown_clrsky ! RRTMGP downward clear-sky flux profiles (W/m2)
181 type(cmpfsw_type), dimension(:), intent(inout) :: &
182 scmpsw ! 2D surface fluxes, components:
183 ! uvbfc - total sky downward uv-b flux (W/m2)
184 ! uvbf0 - clear sky downward uv-b flux (W/m2)
185 ! nirbm - downward nir direct beam flux (W/m2)
186 ! nirdf - downward nir diffused flux (W/m2)
187 ! visbm - downward uv+vis direct beam flux (W/m2)
188 ! visdf - downward uv+vis diffused flux (W/m2)
189
190 ! Local variables
191 type(cmpfsw_type), dimension(rrtmgp_phys_blksz) :: scmpsw_clrsky, scmpsw_allsky
192 type(ty_fluxes_byband) :: flux_allsky, flux_clrsky
193 real(kind_phys) :: tau_rain, tau_snow, ssa_rain, ssa_snow, asy_rain, asy_snow, &
194 tau_prec, asy_prec, ssa_prec, asyw, ssaw, za1, za2, flux_dir, flux_dif
195 real(kind_phys), dimension(rrtmgp_phys_blksz) :: zcf0, zcf1
196 real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt()) :: rng1d
197 real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt(),nLay,rrtmgp_phys_blksz) :: rng3d,rng3d2
198 real(kind_dbl_prec), dimension(sw_gas_props%get_ngpt()*nLay) :: rng2d
199 logical, dimension(rrtmgp_phys_blksz,nLay,sw_gas_props%get_ngpt()) :: maskmcica
200 logical :: cloudy_column, clear_column
201 real(kind_phys), dimension(sw_gas_props%get_nband(),rrtmgp_phys_blksz) :: &
202 sfc_alb_dir, sfc_alb_dif
203 real(kind_phys), dimension(rrtmgp_phys_blksz,nLay+1,sw_gas_props%get_nband()),target :: &
204 fluxsw_up_allsky, fluxsw_up_clrsky, fluxsw_dn_dir_clrsky, fluxsw_dn_allsky, &
205 fluxsw_dn_clrsky, fluxsw_dn_dir_allsky
206 integer :: iband, ibd, ibd_uv, icol, igas, ilay, ix, ix2, iblck
207 integer, dimension(rrtmgp_phys_blksz) :: ipseed_sw, icols
208 type(random_stat) :: rng_stat
209 real(kind_phys), dimension(2,sw_gas_props%get_nband()) :: bandlimits
210 real(kind_phys), dimension(2), parameter :: &
211 nir_uvvis_bnd = (/12850,16000/), &
212 uvb_bnd = (/29000,38000/)
213 real(kind_phys), dimension(rrtmgp_phys_blksz,sw_gas_props%get_ngpt()) :: toa_src_sw
214
215 type(ty_gas_concs) :: gas_concs
216 type(ty_optical_props_2str) :: sw_optical_props_accum, sw_optical_props_aerosol_local, &
217 sw_optical_props_cloudsbyband, sw_optical_props_cnvcloudsbyband, &
218 sw_optical_props_pblcloudsbyband, sw_optical_props_precipbyband, &
219 sw_optical_props_clouds
220
221 ! Initialize CCPP error handling variables
222 errmsg = ''
223 errflg = 0
224
225 if (.not. doswrad) return
226
227 ! ty_gas_concs
228 call check_error_msg('rrtmgp_sw_main_gas_concs_init',gas_concs%init(active_gases_array))
229
230 ! ty_optical_props
231 call check_error_msg('rrtmgp_sw_main_accumulated_optics_init',&
232 sw_optical_props_accum%alloc_2str(rrtmgp_phys_blksz, nlay, sw_gas_props))
233 call check_error_msg('rrtmgp_sw_main_cloud_optics_init',&
234 sw_optical_props_cloudsbyband%alloc_2str(rrtmgp_phys_blksz, nlay, sw_gas_props%get_band_lims_wavenumber()))
235 call check_error_msg('rrtmgp_sw_main_precip_optics_init',&
236 sw_optical_props_precipbyband%alloc_2str(rrtmgp_phys_blksz, nlay, sw_gas_props%get_band_lims_wavenumber()))
237 call check_error_msg('rrtmgp_sw_mian_cloud_sampling_init', &
238 sw_optical_props_clouds%alloc_2str(rrtmgp_phys_blksz, nlay, sw_gas_props))
239 call check_error_msg('rrtmgp_sw_main_aerosol_optics_init',&
240 sw_optical_props_aerosol_local%alloc_2str(rrtmgp_phys_blksz, nlay, sw_gas_props%get_band_lims_wavenumber()))
241 if (dogp_sgs_cnv) then
242 call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics_init',&
243 sw_optical_props_cnvcloudsbyband%alloc_2str(rrtmgp_phys_blksz, nlay, sw_gas_props%get_band_lims_wavenumber()))
244 endif
245 if (dogp_sgs_pbl) then
246 call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics_init',&
247 sw_optical_props_pblcloudsbyband%alloc_2str(rrtmgp_phys_blksz, nlay, sw_gas_props%get_band_lims_wavenumber()))
248 endif
249
250 if (nday .gt. 0) then
251
252 bandlimits = sw_gas_props%get_band_lims_wavenumber()
253 ! ######################################################################################
254 !
255 ! Loop over all (daylit) columns...
256 !
257 ! ######################################################################################
258 do icol=1,nday,rrtmgp_phys_blksz
259 !ix = idx(iCol)
260 !ix2 = idx(iCol + rrtmgp_phys_blksz - 1)
261 icols = idx(icol:icol + rrtmgp_phys_blksz - 1)
262
263 ! Create clear/cloudy indicator
264 zcf0(:) = 1._kind_phys
265 zcf1(:) = 1._kind_phys
266 do iblck = 1, rrtmgp_phys_blksz
267 do ilay=1,nlay
268 zcf0(iblck) = min(zcf0(iblck), 1._kind_phys - cld_frac(icols(iblck),ilay))
269 enddo
270 if (zcf0(iblck) <= ftiny) zcf0(iblck) = 0._kind_phys
271 if (zcf0(iblck) > oneminus) zcf0(iblck) = 1._kind_phys
272 zcf1(iblck) = 1._kind_phys - zcf0(iblck)
273 enddo
274 cloudy_column = any(zcf1 .gt. eps)
275 clear_column = .true.
276 if (cloudy_column) clear_column = .false.
277
278 ! ###################################################################################
279 !
280 ! Initialize/reset
281 !
282 ! ###################################################################################
283 sw_optical_props_clouds%tau = 0._kind_phys
284 sw_optical_props_clouds%ssa = 0._kind_phys
285 sw_optical_props_clouds%g = 0._kind_phys
286 sw_optical_props_accum%tau = 0._kind_phys
287 sw_optical_props_accum%ssa = 0._kind_phys
288 sw_optical_props_accum%g = 0._kind_phys
289 sw_optical_props_cloudsbyband%tau = 0._kind_phys
290 sw_optical_props_cloudsbyband%ssa = 0._kind_phys
291 sw_optical_props_cloudsbyband%g = 0._kind_phys
292 sw_optical_props_precipbyband%tau = 0._kind_phys
293 sw_optical_props_precipbyband%ssa = 0._kind_phys
294 sw_optical_props_precipbyband%g = 0._kind_phys
295 if (dogp_sgs_cnv) then
296 sw_optical_props_cnvcloudsbyband%tau = 0._kind_phys
297 sw_optical_props_cnvcloudsbyband%ssa = 0._kind_phys
298 sw_optical_props_cnvcloudsbyband%g = 0._kind_phys
299 endif
300 if (dogp_sgs_pbl) then
301 sw_optical_props_pblcloudsbyband%tau = 0._kind_phys
302 sw_optical_props_pblcloudsbyband%ssa = 0._kind_phys
303 sw_optical_props_pblcloudsbyband%g = 0._kind_phys
304 endif
305 scmpsw_clrsky= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 )
306 scmpsw_allsky= cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 )
307 cldtausw = 0._kind_phys
308
309 ! ty_fluxes_byband
310 fluxsw_up_allsky = 0._kind_phys
311 fluxsw_dn_allsky = 0._kind_phys
312 fluxsw_dn_dir_allsky = 0._kind_phys
313 fluxsw_up_clrsky = 0._kind_phys
314 fluxsw_dn_clrsky = 0._kind_phys
315 flux_allsky%bnd_flux_up => fluxsw_up_allsky
316 flux_allsky%bnd_flux_dn => fluxsw_dn_allsky
317 flux_allsky%bnd_flux_dn_dir => fluxsw_dn_dir_allsky
318 flux_clrsky%bnd_flux_up => fluxsw_up_clrsky
319 flux_clrsky%bnd_flux_dn => fluxsw_dn_clrsky
320
321 ! ###################################################################################
322 !
323 ! Set gas-concentrations
324 !
325 ! ###################################################################################
326 call check_error_msg('rrtmgp_sw_main_set_vmr_o2', &
327 gas_concs%set_vmr(trim(active_gases_array(istr_o2)), vmr_o2(icols,:)))
328 call check_error_msg('rrtmgp_sw_main_set_vmr_co2', &
329 gas_concs%set_vmr(trim(active_gases_array(istr_co2)),vmr_co2(icols,:)))
330 call check_error_msg('rrtmgp_sw_main_set_vmr_ch4', &
331 gas_concs%set_vmr(trim(active_gases_array(istr_ch4)),vmr_ch4(icols,:)))
332 call check_error_msg('rrtmgp_sw_main_set_vmr_n2o', &
333 gas_concs%set_vmr(trim(active_gases_array(istr_n2o)),vmr_n2o(icols,:)))
334 call check_error_msg('rrtmgp_sw_main_set_vmr_h2o', &
335 gas_concs%set_vmr(trim(active_gases_array(istr_h2o)),vmr_h2o(icols,:)))
336 call check_error_msg('rrtmgp_sw_main_set_vmr_o3', &
337 gas_concs%set_vmr(trim(active_gases_array(istr_o3)), vmr_o3(icols,:)))
338
339 ! ###################################################################################
340 !
341 ! Compute gas-optics
342 !
343 ! ###################################################################################
344
345 call check_error_msg('rrtmgp_sw_main_gas_optics',sw_gas_props%gas_optics(&
346 p_lay(icols,:), & ! IN - Pressure @ layer-centers (Pa)
347 p_lev(icols,:), & ! IN - Pressure @ layer-interfaces (Pa)
348 t_lay(icols,:), & ! IN - Temperature @ layer-centers (K)
349 gas_concs, & ! IN - RRTMGP DDT: trace gas volumne mixing-ratios
350 sw_optical_props_accum, & ! OUT - RRTMGP DDT: Shortwave optical properties, by
351 ! spectral point (tau,ssa,g)
352 toa_src_sw)) ! OUT - TOA incident shortwave radiation (spectral)
353 ! Scale incident flux
354 do iblck = 1, rrtmgp_phys_blksz
355 toa_src_sw(iblck,:) = toa_src_sw(iblck,:)*solcon / sum(toa_src_sw(iblck,:))
356 enddo
357
358 ! ###################################################################################
359 !
360 ! Set surface albedo
361 !
362 ! Use near-IR albedo for bands with wavenumbers extending to 12850cm-1
363 ! Use uv-vis albedo for bands with wavenumbers greater than 16000cm-1
364 ! For overlapping band, average near-IR and us-vis albedos.
365 !
366 ! ###################################################################################
367 do iblck = 1, rrtmgp_phys_blksz
368 do iband=1,sw_gas_props%get_nband()
369 if (bandlimits(1,iband) .lt. nir_uvvis_bnd(1)) then
370 sfc_alb_dir(iband,iblck) = sfc_alb_nir_dir(icols(iblck))
371 sfc_alb_dif(iband,iblck) = sfc_alb_nir_dif(icols(iblck))
372 endif
373 if (bandlimits(1,iband) .eq. nir_uvvis_bnd(1)) then
374 sfc_alb_dir(iband,iblck) = 0.5_kind_phys*(sfc_alb_nir_dir(icols(iblck)) + &
375 sfc_alb_uvvis_dir(icols(iblck)))
376 sfc_alb_dif(iband,iblck) = 0.5_kind_phys*(sfc_alb_nir_dif(icols(iblck)) + &
377 sfc_alb_uvvis_dif(icols(iblck)))
378 ibd = iband
379 endif
380 if (bandlimits(1,iband) .ge. nir_uvvis_bnd(2)) then
381 sfc_alb_dir(iband,iblck) = sfc_alb_uvvis_dir(icols(iblck))
382 sfc_alb_dif(iband,iblck) = sfc_alb_uvvis_dif(icols(iblck))
383 endif
384 if (bandlimits(1,iband) .eq. uvb_bnd(1)) ibd_uv = iband
385 enddo
386 enddo
387
388 ! ###################################################################################
389 !
390 ! Compute optics for cloud(s) and precipitation, sample clouds...
391 !
392 ! ###################################################################################
393 if (cloudy_column) then
394 ! Gridmean/mp-clouds
395 call check_error_msg('rrtmgp_sw_main_cloud_optics',sw_cloud_props%cloud_optics(&
396 cld_lwp(icols,:), & ! IN - Cloud liquid water path
397 cld_iwp(icols,:), & ! IN - Cloud ice water path
398 cld_reliq(icols,:), & ! IN - Cloud liquid effective radius
399 cld_reice(icols,:), & ! IN - Cloud ice effective radius
400 sw_optical_props_cloudsbyband)) ! OUT - RRTMGP DDT: Shortwave optical properties,
401 ! in each band (tau,ssa,g)
402 cldtausw(icols,:) = sw_optical_props_cloudsbyband%tau(:,:,11)
403
404 ! Include convective clouds?
405 if (dogp_sgs_cnv) then
406 ! Compute
407 call check_error_msg('rrtmgp_sw_main_cnv_cloud_optics',sw_cloud_props%cloud_optics(&
408 cld_cnv_lwp(icols,:), & ! IN - Convective cloud liquid water path (g/m2)
409 cld_cnv_iwp(icols,:), & ! IN - Convective cloud ice water path (g/m2)
410 cld_cnv_reliq(icols,:), & ! IN - Convective cloud liquid effective radius (microns)
411 cld_cnv_reice(icols,:), & ! IN - Convective cloud ice effective radius (microns)
412 sw_optical_props_cnvcloudsbyband)) ! OUT - RRTMGP DDT containing convective cloud radiative properties
413 ! in each band
414 ! Increment
415 call check_error_msg('rrtmgp_sw_main_increment_cnvclouds_to_clouds',&
416 sw_optical_props_cnvcloudsbyband%increment(sw_optical_props_cloudsbyband))
417 endif
418
419 ! Include PBL clouds?
420 if (dogp_sgs_pbl) then
421 ! Compute
422 call check_error_msg('rrtmgp_sw_main_pbl_cloud_optics',sw_cloud_props%cloud_optics(&
423 cld_pbl_lwp(icols,:), & ! IN - PBL cloud liquid water path (g/m2)
424 cld_pbl_iwp(icols,:), & ! IN - PBL cloud ice water path (g/m2)
425 cld_pbl_reliq(icols,:), & ! IN - PBL cloud liquid effective radius (microns)
426 cld_pbl_reice(icols,:), & ! IN - PBL cloud ice effective radius (microns)
427 sw_optical_props_pblcloudsbyband)) ! OUT - RRTMGP DDT containing PBL cloud radiative properties
428 ! in each band
429 ! Increment
430 call check_error_msg('rrtmgp_sw_main_increment_pblclouds_to_clouds',&
431 sw_optical_props_pblcloudsbyband%increment(sw_optical_props_cloudsbyband))
432 endif
433
434 ! Cloud precipitation optics: rain and snow(+groupel)
435 do iblck = 1, rrtmgp_phys_blksz
436 do ilay=1,nlay
437 if (cld_frac(icols(iblck),ilay) .gt. ftiny) then
438 ! Rain/Snow optical depth (No band dependence)
439 tau_rain = cld_rwp(icols(iblck),ilay)*a0r
440 if (cld_swp(icols(iblck),ilay) .gt. 0. .and. cld_resnow(icols(iblck),ilay) .gt. 10._kind_phys) then
441 tau_snow = cld_swp(icols(iblck),ilay)*1.09087*(a0s + a1s/(1.0315*cld_resnow(icols(iblck),ilay))) ! fu's formula
442 else
443 tau_snow = 0._kind_phys
444 endif
445
446 ! Rain/Snow single-scattering albedo and asymmetry (Band dependent)
447 do iband=1,sw_gas_props%get_nband()
448 ! By species
449 ssa_rain = tau_rain*(1.-b0r(iband))
450 asy_rain = ssa_rain*c0r(iband)
451 ssa_snow = tau_snow*(1.-(b0s(iband)+b1s(iband)*1.0315*cld_resnow(icols(iblck),ilay)))
452 asy_snow = ssa_snow*c0s(iband)
453 ! Combine
454 tau_prec = max(1.e-12_kind_phys, tau_rain + tau_snow)
455 ssa_prec = max(1.e-12_kind_phys, ssa_rain + ssa_snow)
456 asy_prec = max(1.e-12_kind_phys, asy_rain + asy_snow)
457 asyw = asy_prec/max(1.e-12_kind_phys, ssa_prec)
458 ssaw = min(1._kind_phys-0.000001, ssa_prec/tau_prec)
459 za1 = asyw * asyw
460 za2 = ssaw * za1
461 sw_optical_props_precipbyband%tau(iblck,ilay,iband) = (1._kind_phys - za2) * tau_prec
462 sw_optical_props_precipbyband%ssa(iblck,ilay,iband) = (ssaw - za2) / (1._kind_phys - za2)
463 sw_optical_props_precipbyband%g(iblck,ilay,iband) = asyw/(1+asyw)
464 enddo
465 endif
466 enddo
467 enddo
468 ! Increment
469 call check_error_msg('rrtmgp_sw_main_increment_precip_to_clouds',&
470 sw_optical_props_precipbyband%increment(sw_optical_props_cloudsbyband))
471
472 ! ###################################################################################
473 !
474 ! Cloud-sampling
475 !
476 ! ###################################################################################
477 ! Change random number seed value for each radiation invocation (isubc_sw =1 or 2).
478 if(isubc_sw == 1) then ! advance prescribed permutation seed
479 do iblck = 1, rrtmgp_phys_blksz
480 ipseed_sw(iblck) = sw_gas_props%get_ngpt() + icols(iblck)
481 enddo
482 elseif (isubc_sw == 2) then ! use input array of permutaion seeds
483 do iblck = 1, rrtmgp_phys_blksz
484 ipseed_sw(iblck) = icseed_sw(icols(iblck))
485 enddo
486 endif
487
488 ! Call RNG
489 do iblck = 1, rrtmgp_phys_blksz
490 call random_setseed(ipseed_sw(iblck),rng_stat)
491 ! Use same rng for each layer
492 if (iovr == iovr_max) then
493 call random_number(rng1d,rng_stat)
494 do ilay=1,nlay
495 rng3d(:,ilay,iblck) = rng1d
496 enddo
497 else
498 do ilay=1,nlay
499 call random_number(rng1d,rng_stat)
500 rng3d(:,ilay,iblck) = rng1d
501 enddo
502 endif
503 enddo
504
505 ! Cloud-overlap.
506 ! Maximum-random, random or maximum.
507 if (iovr == iovr_maxrand .or. iovr == iovr_rand .or. iovr == iovr_max) then
508 call sampled_mask(real(rng3d, kind=kind_phys), cld_frac(icols,:), maskmcica)
509 endif
510 ! Exponential decorrelation length overlap
511 if (iovr == iovr_dcorr) then
512 do iblck = 1, rrtmgp_phys_blksz
513 ! Generate second RNG
514 call random_setseed(ipseed_sw(iblck),rng_stat)
515 call random_number(rng2d,rng_stat)
516 rng3d2(:,:,iblck) = reshape(source = rng2d,shape=[sw_gas_props%get_ngpt(),nlay])
517 enddo
518 !
519 call sampled_mask(real(rng3d, kind=kind_phys), cld_frac(icols,:), maskmcica, &
520 overlap_param = cloud_overlap_param(icols,1:nlay-1), randoms2 = real(rng3d2, kind=kind_phys))
521 endif
522 ! Exponential or Exponential-random
523 if (iovr == iovr_exp .or. iovr == iovr_exprand) then
524 call sampled_mask(real(rng3d, kind=kind_phys), cld_frac(icols,:), maskmcica, &
525 overlap_param = cloud_overlap_param(icols,1:nlay-1))
526 endif
527 ! Sampling. Map band optical depth to each g-point using McICA
528 call check_error_msg('rrtmgp_sw_main_cloud_sampling',&
529 draw_samples(maskmcica, .true., &
530 sw_optical_props_cloudsbyband, sw_optical_props_clouds))
531 endif ! cloudy_column
532
533 ! ###################################################################################
534 !
535 ! Compute clear-sky fluxes (gaseous+aerosol)
536 !
537 ! ###################################################################################
538 ! Increment optics (always)
539 sw_optical_props_aerosol_local%tau = aersw_tau(icols,:,:)
540 sw_optical_props_aerosol_local%ssa = aersw_ssa(icols,:,:)
541 sw_optical_props_aerosol_local%g = aersw_g(icols,:,:)
542 call check_error_msg('rrtmgp_sw_main_increment_aerosol_to_clrsky', &
543 sw_optical_props_aerosol_local%increment(sw_optical_props_accum))
544
545 ! Compute clear-sky fluxes (Yes for no-clouds. Optional for cloudy scenes)
546 if (clear_column .or. doswclrsky) then
547 call check_error_msg('rrtmgp_sw_main_rte_sw_clrsky',rte_sw( &
548 sw_optical_props_accum, & ! IN - optical-properties
549 top_at_1, & ! IN - veritcal ordering flag
550 coszen(icols), & ! IN - Cosine of solar zenith angle
551 toa_src_sw, & ! IN - incident solar flux at TOA
552 sfc_alb_dir, & ! IN - Shortwave surface albedo (direct)
553 sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse)
554 flux_clrsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand)
555
556 ! Store fluxes
557 fluxswup_clrsky(icols,:) = sum(flux_clrsky%bnd_flux_up, dim=3)
558 fluxswdown_clrsky(icols,:) = sum(flux_clrsky%bnd_flux_dn, dim=3)
559
560 ! Compute surface downward beam/diffused flux components
561 do iblck = 1, rrtmgp_phys_blksz
562 do iband=1,sw_gas_props%get_nband()
563 flux_dir = flux_clrsky%bnd_flux_dn(iblck,isfc,iband)
564 flux_dif = 0._kind_phys
565 ! Near-IR bands
566 if (iband < ibd) then
567 scmpsw_clrsky(iblck)%nirbm = scmpsw_clrsky(iblck)%nirbm + flux_dir
568 scmpsw_clrsky(iblck)%nirdf = scmpsw_clrsky(iblck)%nirdf + flux_dif
569 endif
570 ! Transition band
571 if (iband == ibd) then
572 scmpsw_clrsky(iblck)%nirbm = scmpsw_clrsky(iblck)%nirbm + flux_dir*0.5_kind_phys
573 scmpsw_clrsky(iblck)%nirdf = scmpsw_clrsky(iblck)%nirdf + flux_dif*0.5_kind_phys
574 scmpsw_clrsky(iblck)%visbm = scmpsw_clrsky(iblck)%visbm + flux_dir*0.5_kind_phys
575 scmpsw_clrsky(iblck)%visdf = scmpsw_clrsky(iblck)%visdf + flux_dif*0.5_kind_phys
576 endif
577 ! UV-VIS bands
578 if (iband > ibd) then
579 scmpsw_clrsky(iblck)%visbm = scmpsw_clrsky(iblck)%visbm + flux_dir
580 scmpsw_clrsky(iblck)%visdf = scmpsw_clrsky(iblck)%visdf + flux_dif
581 endif
582 ! uv-b surface downward flux
583 scmpsw_clrsky(iblck)%uvbfc = flux_clrsky%bnd_flux_dn(iblck,isfc,ibd_uv)
584 enddo
585 enddo
586 else
587 fluxswup_clrsky(icols,:) = 0._kind_phys
588 fluxswdown_clrsky(icols,:) = 0._kind_phys
589 scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 )
590 endif
591
592 ! ###################################################################################
593 !
594 ! All-sky fluxes (clear-sky + clouds + precipitation)
595 !
596 ! ###################################################################################
597 if (cloudy_column) then
598 ! Delta scale
599 !call check_error_msg('rrtmgp_sw_main_delta_scale',sw_optical_props_clouds%delta_scale())
600
601 ! Increment
602 call check_error_msg('rrtmgp_sw_main_increment_clouds_to_clrsky', &
603 sw_optical_props_clouds%increment(sw_optical_props_accum))
604
605 ! Compute fluxes
606 call check_error_msg('rrtmgp_sw_main_rte_sw_allsky',rte_sw( &
607 sw_optical_props_accum, & ! IN - optical-properties
608 top_at_1, & ! IN - veritcal ordering flag
609 coszen(icols), & ! IN - Cosine of solar zenith angle
610 toa_src_sw, & ! IN - incident solar flux at TOA
611 sfc_alb_dir, & ! IN - Shortwave surface albedo (direct)
612 sfc_alb_dif, & ! IN - Shortwave surface albedo (diffuse)
613 flux_allsky)) ! OUT - Fluxes, clear-sky, 3D (1,nLay,nBand)
614
615 ! Store fluxes
616 fluxswup_allsky(icols,:) = sum(flux_allsky%bnd_flux_up, dim=3)
617 fluxswdown_allsky(icols,:) = sum(flux_allsky%bnd_flux_dn, dim=3)
618
619 ! Compute and store downward beam/diffused flux components
620 do iblck = 1, rrtmgp_phys_blksz
621 ! Loop over bands, sum fluxes...
622 do iband=1,sw_gas_props%get_nband()
623 flux_dir = flux_allsky%bnd_flux_dn_dir(iblck,isfc,iband)
624 flux_dif = flux_allsky%bnd_flux_dn(iblck,isfc,iband) - flux_allsky%bnd_flux_dn_dir(iblck,isfc,iband)
625 ! Near-IR bands
626 if (iband < ibd) then
627 scmpsw_allsky(iblck)%nirbm = scmpsw_allsky(iblck)%nirbm + flux_dir
628 scmpsw_allsky(iblck)%nirdf = scmpsw_allsky(iblck)%nirdf + flux_dif
629 endif
630 ! Transition band
631 if (iband == ibd) then
632 scmpsw_allsky(iblck)%nirbm = scmpsw_allsky(iblck)%nirbm + flux_dir*0.5_kind_phys
633 scmpsw_allsky(iblck)%nirdf = scmpsw_allsky(iblck)%nirdf + flux_dif*0.5_kind_phys
634 scmpsw_allsky(iblck)%visbm = scmpsw_allsky(iblck)%visbm + flux_dir*0.5_kind_phys
635 scmpsw_allsky(iblck)%visdf = scmpsw_allsky(iblck)%visdf + flux_dif*0.5_kind_phys
636 endif
637 ! UV-VIS bands
638 if (iband > ibd) then
639 scmpsw_allsky(iblck)%visbm = scmpsw_allsky(iblck)%visbm + flux_dir
640 scmpsw_allsky(iblck)%visdf = scmpsw_allsky(iblck)%visdf + flux_dif
641 endif
642 ! uv-b surface downward flux
643 scmpsw_allsky(iblck)%uvbfc = flux_allsky%bnd_flux_dn(iblck,isfc,ibd_uv)
644 enddo
645 ! Store surface downward beam/diffused flux components
646 if (zcf1(iblck) .gt. eps) then
647 scmpsw(icols(iblck))%nirbm = scmpsw_allsky(iblck)%nirbm
648 scmpsw(icols(iblck))%nirdf = scmpsw_allsky(iblck)%nirdf
649 scmpsw(icols(iblck))%visbm = scmpsw_allsky(iblck)%visbm
650 scmpsw(icols(iblck))%visdf = scmpsw_allsky(iblck)%visdf
651 scmpsw(icols(iblck))%uvbfc = flux_allsky%bnd_flux_dn(iblck,isfc,ibd_uv)
652 else
653 scmpsw(icols(iblck))%nirbm = scmpsw_clrsky(iblck)%nirbm
654 scmpsw(icols(iblck))%nirdf = scmpsw_clrsky(iblck)%nirdf
655 scmpsw(icols(iblck))%visbm = scmpsw_clrsky(iblck)%visbm
656 scmpsw(icols(iblck))%visdf = scmpsw_clrsky(iblck)%visdf
657 scmpsw(icols(iblck))%uvbfc = flux_clrsky%bnd_flux_dn(iblck,isfc,ibd_uv)
658 endif
659 scmpsw(icols(iblck))%uvbf0 = flux_clrsky%bnd_flux_dn(iblck,isfc,ibd_uv)
660 enddo
661 else ! No clouds
662 fluxswup_allsky(icols,:) = sum(flux_clrsky%bnd_flux_up, dim=3)
663 fluxswdown_allsky(icols,:) = sum(flux_clrsky%bnd_flux_dn, dim=3)
664 do iblck = 1, rrtmgp_phys_blksz
665 scmpsw(icols(iblck))%nirbm = scmpsw_clrsky(iblck)%nirbm
666 scmpsw(icols(iblck))%nirdf = scmpsw_clrsky(iblck)%nirdf
667 scmpsw(icols(iblck))%visbm = scmpsw_clrsky(iblck)%visbm
668 scmpsw(icols(iblck))%visdf = scmpsw_clrsky(iblck)%visdf
669 scmpsw(icols(iblck))%uvbfc = flux_clrsky%bnd_flux_dn(iblck,isfc,ibd_uv)
670 scmpsw(icols(iblck))%uvbf0 = flux_clrsky%bnd_flux_dn(iblck,isfc,ibd_uv)
671 enddo
672 endif
673 !
674 enddo ! nday
675 else
676 fluxswup_allsky(:,:) = 0._kind_phys
677 fluxswdown_allsky(:,:) = 0._kind_phys
678 fluxswup_clrsky(:,:) = 0._kind_phys
679 fluxswdown_clrsky(:,:) = 0._kind_phys
680 scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 )
681 endif
682 end subroutine rrtmgp_sw_main_run
683end module rrtmgp_sw_main
mersenne_twister::random_number
Definition mersenne_twister.f:201
mersenne_twister::random_setseed
Definition mersenne_twister.f:197
mersenne_twister
This module calculates random numbers using the Mersenne twister.
Definition mersenne_twister.f:162
module_radsw_parameters
This module is for specifying the band structures and program parameters used by the RRTMG-SW scheme.
Definition radsw_param.f:62
radiation_tools
This module contains tools for radiation.
Definition radiation_tools.F90:5
rrtmgp_sampling
This module provides a simple implementation of sampling for the Monte Carlo Independent Pixel Approx...
Definition rrtmgp_sampling.F90:24
rrtmgp_sw_cloud_optics
This module contains the cloud optics properties calculation for RRTMGP-SW.
Definition rrtmgp_sw_cloud_optics.F90:5
rrtmgp_sw_gas_optics
This module contains a routine to initialize the k-distribution data used by the RRTMGP shortwave rad...
Definition rrtmgp_sw_gas_optics.F90:6
rrtmgp_sw_main
This module contain the RRTMGP-SW radiation scheme.
Definition rrtmgp_sw_main.F90:5
mersenne_twister::random_stat
Generator state.
Definition mersenne_twister.f:187
module_radsw_parameters::cmpfsw_type
derived type for special components of surface SW fluxes
Definition radsw_param.f:111