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