Line data Source code
1 :
2 : module radsw
3 : !-----------------------------------------------------------------------
4 : !
5 : ! Purpose: Solar radiation calculations.
6 : !
7 : !-----------------------------------------------------------------------
8 : use shr_kind_mod, only: r8 => shr_kind_r8
9 : use ppgrid, only: pcols, pver, pverp
10 : use cam_abortutils, only: endrun
11 : use cam_history, only: outfld
12 : use scamMod, only: single_column,scm_crm_mode,have_asdir, &
13 : asdirobs, have_asdif, asdifobs, have_aldir, &
14 : aldirobs, have_aldif, aldifobs
15 : use cam_logfile, only: iulog
16 : use parrrsw, only: nbndsw, ngptsw
17 : use rrtmg_sw_init, only: rrtmg_sw_ini
18 : use rrtmg_sw_rad, only: rrtmg_sw
19 : use perf_mod, only: t_startf, t_stopf
20 : use radconstants, only: idx_sw_diag
21 :
22 : implicit none
23 :
24 : private
25 : save
26 :
27 : real(r8) :: fractional_solar_irradiance(1:nbndsw) ! fraction of solar irradiance in each band
28 : real(r8) :: solar_band_irrad(1:nbndsw) ! rrtmg-assumed solar irradiance in each sw band
29 :
30 : ! Public methods
31 :
32 : public ::&
33 : radsw_init, &! initialize constants
34 : rad_rrtmg_sw ! driver for solar radiation code
35 :
36 : ! Flag for cloud overlap method
37 : ! 0=clear, 1=random, 2=maximum-random, 3=maximum
38 : integer, parameter :: icld = 2
39 :
40 : !===============================================================================
41 : CONTAINS
42 : !===============================================================================
43 :
44 38400 : subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , &
45 : E_pmid ,E_cld , &
46 : E_aer_tau,E_aer_tau_w,E_aer_tau_w_g,E_aer_tau_w_f, &
47 : eccf ,E_coszrs ,solin ,sfac , &
48 : E_asdir ,E_asdif ,E_aldir ,E_aldif , &
49 : qrs ,qrsc ,fsnt ,fsntc ,fsntoa,fsutoa, &
50 : fsntoac ,fsnirtoa ,fsnrtoac ,fsnrtoaq ,fsns , &
51 : fsnsc ,fsdsc ,fsds ,sols ,soll , &
52 : solsd ,solld ,fns ,fcns , &
53 : Nday ,Nnite ,IdxDay ,IdxNite , &
54 : su ,sd , &
55 : E_cld_tau, E_cld_tau_w, E_cld_tau_w_g, E_cld_tau_w_f, &
56 : old_convert)
57 :
58 :
59 : !-----------------------------------------------------------------------
60 : !
61 : ! Purpose:
62 : ! Solar radiation code
63 : !
64 : ! Method:
65 : ! mji/rrtmg
66 : ! RRTMG, two-stream, with McICA
67 : !
68 : ! Divides solar spectrum into 14 intervals from 0.2-12.2 micro-meters.
69 : ! solar flux fractions specified for each interval. allows for
70 : ! seasonally and diurnally varying solar input. Includes molecular,
71 : ! cloud, aerosol, and surface scattering, along with h2o,o3,co2,o2,cloud,
72 : ! and surface absorption. Computes delta-eddington reflections and
73 : ! transmissions assuming homogeneously mixed layers. Adds the layers
74 : ! assuming scattering between layers to be isotropic, and distinguishes
75 : ! direct solar beam from scattered radiation.
76 : !
77 : ! Longitude loops are broken into 1 or 2 sections, so that only daylight
78 : ! (i.e. coszrs > 0) computations are done.
79 : !
80 : ! Note that an extra layer above the model top layer is added.
81 : !
82 : ! mks units are used.
83 : !
84 : ! Special diagnostic calculation of the clear sky surface and total column
85 : ! absorbed flux is also done for cloud forcing diagnostics.
86 : !
87 : !-----------------------------------------------------------------------
88 :
89 : use cmparray_mod, only: CmpDayNite, ExpDayNite
90 : use phys_control, only: phys_getopts
91 : use mcica_subcol_gen_sw, only: mcica_subcol_sw
92 : use physconst, only: cpair
93 : use rrtmg_state, only: rrtmg_state_t
94 :
95 : ! Minimum cloud amount (as a fraction of the grid-box area) to
96 : ! distinguish from clear sky
97 : real(r8), parameter :: cldmin = 1.0e-80_r8
98 :
99 : ! Decimal precision of cloud amount (0 -> preserve full resolution;
100 : ! 10^-n -> preserve n digits of cloud amount)
101 : real(r8), parameter :: cldeps = 0.0_r8
102 :
103 : ! Input arguments
104 : integer, intent(in) :: lchnk ! chunk identifier
105 : integer, intent(in) :: ncol ! number of atmospheric columns
106 : integer, intent(in) :: rrtmg_levs ! number of levels rad is applied
107 :
108 : type(rrtmg_state_t), intent(in) :: r_state
109 :
110 : integer, intent(in) :: Nday ! Number of daylight columns
111 : integer, intent(in) :: Nnite ! Number of night columns
112 : integer, intent(in), dimension(pcols) :: IdxDay ! Indicies of daylight coumns
113 : integer, intent(in), dimension(pcols) :: IdxNite ! Indicies of night coumns
114 :
115 : real(r8), intent(in) :: E_pmid(pcols,pver) ! Level pressure (Pascals)
116 : real(r8), intent(in) :: E_cld(pcols,pver) ! Fractional cloud cover
117 :
118 : real(r8), intent(in) :: E_aer_tau (pcols, 0:pver, nbndsw) ! aerosol optical depth
119 : real(r8), intent(in) :: E_aer_tau_w (pcols, 0:pver, nbndsw) ! aerosol OD * ssa
120 : real(r8), intent(in) :: E_aer_tau_w_g(pcols, 0:pver, nbndsw) ! aerosol OD * ssa * asm
121 : real(r8), intent(in) :: E_aer_tau_w_f(pcols, 0:pver, nbndsw) ! aerosol OD * ssa * fwd
122 :
123 : real(r8), intent(in) :: eccf ! Eccentricity factor (1./earth-sun dist^2)
124 : real(r8), intent(in) :: E_coszrs(pcols) ! Cosine solar zenith angle
125 : real(r8), intent(in) :: E_asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad
126 : real(r8), intent(in) :: E_aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad
127 : real(r8), intent(in) :: E_asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad
128 : real(r8), intent(in) :: E_aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad
129 : real(r8), intent(in) :: sfac(nbndsw) ! factor to account for solar variability in each band
130 :
131 : real(r8), optional, intent(in) :: E_cld_tau (nbndsw, pcols, pver) ! cloud optical depth
132 : real(r8), optional, intent(in) :: E_cld_tau_w (nbndsw, pcols, pver) ! cloud optical
133 : real(r8), optional, intent(in) :: E_cld_tau_w_g(nbndsw, pcols, pver) ! cloud optical
134 : real(r8), optional, intent(in) :: E_cld_tau_w_f(nbndsw, pcols, pver) ! cloud optical
135 : logical, optional, intent(in) :: old_convert
136 :
137 : ! Output arguments
138 :
139 : real(r8), intent(out) :: solin(pcols) ! Incident solar flux
140 : real(r8), intent(out) :: qrs (pcols,pver) ! Solar heating rate
141 : real(r8), intent(out) :: qrsc(pcols,pver) ! Clearsky solar heating rate
142 : real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux
143 : real(r8), intent(out) :: fsnt(pcols) ! Total column absorbed solar flux
144 : real(r8), intent(out) :: fsntoa(pcols) ! Net solar flux at TOA
145 : real(r8), intent(out) :: fsutoa(pcols) ! Upward solar flux at TOA
146 : real(r8), intent(out) :: fsds(pcols) ! Flux shortwave downwelling surface
147 :
148 : real(r8), intent(out) :: fsnsc(pcols) ! Clear sky surface absorbed solar flux
149 : real(r8), intent(out) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux
150 : real(r8), intent(out) :: fsntc(pcols) ! Clear sky total column absorbed solar flx
151 : real(r8), intent(out) :: fsntoac(pcols) ! Clear sky net solar flx at TOA
152 : real(r8), intent(out) :: sols(pcols) ! Direct solar rad on surface (< 0.7)
153 : real(r8), intent(out) :: soll(pcols) ! Direct solar rad on surface (>= 0.7)
154 : real(r8), intent(out) :: solsd(pcols) ! Diffuse solar rad on surface (< 0.7)
155 : real(r8), intent(out) :: solld(pcols) ! Diffuse solar rad on surface (>= 0.7)
156 : real(r8), intent(out) :: fsnirtoa(pcols) ! Near-IR flux absorbed at toa
157 : real(r8), intent(out) :: fsnrtoac(pcols) ! Clear sky near-IR flux absorbed at toa
158 : real(r8), intent(out) :: fsnrtoaq(pcols) ! Net near-IR flux at toa >= 0.7 microns
159 :
160 : real(r8), intent(out) :: fns(pcols,pverp) ! net flux at interfaces
161 : real(r8), intent(out) :: fcns(pcols,pverp) ! net clear-sky flux at interfaces
162 :
163 : real(r8), pointer, dimension(:,:,:) :: su ! shortwave spectral flux up
164 : real(r8), pointer, dimension(:,:,:) :: sd ! shortwave spectral flux down
165 :
166 : !---------------------------Local variables-----------------------------
167 :
168 : ! Local and reordered copies of the intent(in) variables
169 :
170 : real(r8) :: pmid(pcols,pver) ! Level pressure (Pascals)
171 :
172 76800 : real(r8) :: cld(pcols,rrtmg_levs-1) ! Fractional cloud cover
173 76800 : real(r8) :: cicewp(pcols,rrtmg_levs-1) ! in-cloud cloud ice water path
174 76800 : real(r8) :: cliqwp(pcols,rrtmg_levs-1) ! in-cloud cloud liquid water path
175 76800 : real(r8) :: rel(pcols,rrtmg_levs-1) ! Liquid effective drop size (microns)
176 76800 : real(r8) :: rei(pcols,rrtmg_levs-1) ! Ice effective drop size (microns)
177 :
178 : real(r8) :: coszrs(pcols) ! Cosine solar zenith angle
179 : real(r8) :: asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad
180 : real(r8) :: aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad
181 : real(r8) :: asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad
182 : real(r8) :: aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad
183 :
184 76800 : real(r8) :: h2ovmr(pcols,rrtmg_levs) ! h2o volume mixing ratio
185 76800 : real(r8) :: o3vmr(pcols,rrtmg_levs) ! o3 volume mixing ratio
186 76800 : real(r8) :: co2vmr(pcols,rrtmg_levs) ! co2 volume mixing ratio
187 76800 : real(r8) :: ch4vmr(pcols,rrtmg_levs) ! ch4 volume mixing ratio
188 76800 : real(r8) :: o2vmr(pcols,rrtmg_levs) ! o2 volume mixing ratio
189 76800 : real(r8) :: n2ovmr(pcols,rrtmg_levs) ! n2o volume mixing ratio
190 :
191 : real(r8) :: tsfc(pcols) ! surface temperature
192 :
193 : integer :: dyofyr ! Set to day of year for Earth/Sun distance calculation in
194 : ! rrtmg_sw, or pass in adjustment directly into adjes
195 : real(r8) :: solvar(nbndsw) ! solar irradiance variability in each band
196 :
197 : integer, parameter :: nsubcsw = ngptsw ! rrtmg_sw g-point (quadrature point) dimension
198 : integer :: permuteseed ! permute seed for sub-column generator
199 :
200 : real(r8) :: diagnostic_od(pcols, pver) ! cloud optical depth - diagnostic temp variable
201 :
202 76800 : real(r8) :: tauc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud optical depth
203 76800 : real(r8) :: ssac_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud single scat. albedo
204 76800 : real(r8) :: asmc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud asymmetry parameter
205 76800 : real(r8) :: fsfc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud forward scattering fraction
206 :
207 76800 : real(r8) :: tau_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer optical depth
208 76800 : real(r8) :: ssa_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer single scat. albedo
209 76800 : real(r8) :: asm_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer asymmetry parameter
210 :
211 76800 : real(r8) :: cld_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud fraction
212 76800 : real(r8) :: rei_stosw(pcols, rrtmg_levs-1) ! stochastic ice particle size
213 76800 : real(r8) :: rel_stosw(pcols, rrtmg_levs-1) ! stochastic liquid particle size
214 76800 : real(r8) :: cicewp_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud ice water path
215 76800 : real(r8) :: cliqwp_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud liquid wter path
216 76800 : real(r8) :: tauc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud optical depth (optional)
217 76800 : real(r8) :: ssac_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud single scat. albedo (optional)
218 76800 : real(r8) :: asmc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud asymmetry parameter (optional)
219 76800 : real(r8) :: fsfc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud forward scattering fraction (optional)
220 :
221 : real(r8), parameter :: dps = 1._r8/86400._r8 ! Inverse of seconds per day
222 :
223 76800 : real(r8) :: swuflx(pcols,rrtmg_levs+1) ! Total sky shortwave upward flux (W/m2)
224 76800 : real(r8) :: swdflx(pcols,rrtmg_levs+1) ! Total sky shortwave downward flux (W/m2)
225 76800 : real(r8) :: swhr(pcols,rrtmg_levs) ! Total sky shortwave radiative heating rate (K/d)
226 76800 : real(r8) :: swuflxc(pcols,rrtmg_levs+1) ! Clear sky shortwave upward flux (W/m2)
227 76800 : real(r8) :: swdflxc(pcols,rrtmg_levs+1) ! Clear sky shortwave downward flux (W/m2)
228 76800 : real(r8) :: swhrc(pcols,rrtmg_levs) ! Clear sky shortwave radiative heating rate (K/d)
229 76800 : real(r8) :: swuflxs(nbndsw,pcols,rrtmg_levs+1) ! Shortwave spectral flux up
230 76800 : real(r8) :: swdflxs(nbndsw,pcols,rrtmg_levs+1) ! Shortwave spectral flux down
231 :
232 76800 : real(r8) :: dirdnuv(pcols,rrtmg_levs+1) ! Direct downward shortwave flux, UV/vis
233 76800 : real(r8) :: difdnuv(pcols,rrtmg_levs+1) ! Diffuse downward shortwave flux, UV/vis
234 76800 : real(r8) :: dirdnir(pcols,rrtmg_levs+1) ! Direct downward shortwave flux, near-IR
235 76800 : real(r8) :: difdnir(pcols,rrtmg_levs+1) ! Diffuse downward shortwave flux, near-IR
236 :
237 : ! Added for net near-IR diagnostic
238 76800 : real(r8) :: ninflx(pcols,rrtmg_levs+1) ! Net shortwave flux, near-IR
239 76800 : real(r8) :: ninflxc(pcols,rrtmg_levs+1) ! Net clear sky shortwave flux, near-IR
240 :
241 : ! Other
242 :
243 : integer :: i, k, ns ! indices
244 :
245 : ! Cloud radiative property arrays
246 : real(r8) :: tauxcl(pcols,0:pver) ! water cloud extinction optical depth
247 : real(r8) :: tauxci(pcols,0:pver) ! ice cloud extinction optical depth
248 : real(r8) :: wcl(pcols,0:pver) ! liquid cloud single scattering albedo
249 : real(r8) :: gcl(pcols,0:pver) ! liquid cloud asymmetry parameter
250 : real(r8) :: fcl(pcols,0:pver) ! liquid cloud forward scattered fraction
251 : real(r8) :: wci(pcols,0:pver) ! ice cloud single scattering albedo
252 : real(r8) :: gci(pcols,0:pver) ! ice cloud asymmetry parameter
253 : real(r8) :: fci(pcols,0:pver) ! ice cloud forward scattered fraction
254 :
255 : ! Aerosol radiative property arrays
256 : real(r8) :: tauxar(pcols,0:pver) ! aerosol extinction optical depth
257 : real(r8) :: wa(pcols,0:pver) ! aerosol single scattering albedo
258 : real(r8) :: ga(pcols,0:pver) ! aerosol asymmetry parameter
259 : real(r8) :: fa(pcols,0:pver) ! aerosol forward scattered fraction
260 :
261 : ! CRM
262 : real(r8) :: fus(pcols,pverp) ! Upward flux (added for CRM)
263 : real(r8) :: fds(pcols,pverp) ! Downward flux (added for CRM)
264 : real(r8) :: fusc(pcols,pverp) ! Upward clear-sky flux (added for CRM)
265 : real(r8) :: fdsc(pcols,pverp) ! Downward clear-sky flux (added for CRM)
266 :
267 : integer :: kk
268 :
269 76800 : real(r8) :: pmidmb(pcols,rrtmg_levs) ! Level pressure (hPa)
270 76800 : real(r8) :: pintmb(pcols,rrtmg_levs+1) ! Model interface pressure (hPa)
271 76800 : real(r8) :: tlay(pcols,rrtmg_levs) ! mid point temperature
272 76800 : real(r8) :: tlev(pcols,rrtmg_levs+1) ! interface temperature
273 :
274 : !-----------------------------------------------------------------------
275 : ! START OF CALCULATION
276 : !-----------------------------------------------------------------------
277 :
278 : ! Initialize output fields:
279 :
280 591360 : fsds(1:ncol) = 0.0_r8
281 :
282 591360 : fsnirtoa(1:ncol) = 0.0_r8
283 591360 : fsnrtoac(1:ncol) = 0.0_r8
284 591360 : fsnrtoaq(1:ncol) = 0.0_r8
285 :
286 591360 : fsns(1:ncol) = 0.0_r8
287 591360 : fsnsc(1:ncol) = 0.0_r8
288 591360 : fsdsc(1:ncol) = 0.0_r8
289 :
290 591360 : fsnt(1:ncol) = 0.0_r8
291 591360 : fsntc(1:ncol) = 0.0_r8
292 591360 : fsntoa(1:ncol) = 0.0_r8
293 591360 : fsutoa(1:ncol) = 0.0_r8
294 591360 : fsntoac(1:ncol) = 0.0_r8
295 :
296 591360 : solin(1:ncol) = 0.0_r8
297 :
298 591360 : sols(1:ncol) = 0.0_r8
299 591360 : soll(1:ncol) = 0.0_r8
300 591360 : solsd(1:ncol) = 0.0_r8
301 591360 : solld(1:ncol) = 0.0_r8
302 :
303 18961920 : qrs (1:ncol,1:pver) = 0.0_r8
304 18961920 : qrsc(1:ncol,1:pver) = 0.0_r8
305 19553280 : fns(1:ncol,1:pverp) = 0.0_r8
306 19553280 : fcns(1:ncol,1:pverp) = 0.0_r8
307 38400 : if (single_column.and.scm_crm_mode) then
308 0 : fus(1:ncol,1:pverp) = 0.0_r8
309 0 : fds(1:ncol,1:pverp) = 0.0_r8
310 0 : fusc(:ncol,:pverp) = 0.0_r8
311 0 : fdsc(:ncol,:pverp) = 0.0_r8
312 : endif
313 :
314 38400 : if (associated(su)) su(1:ncol,:,:) = 0.0_r8
315 38400 : if (associated(sd)) sd(1:ncol,:,:) = 0.0_r8
316 :
317 : ! If night everywhere, return:
318 38400 : if ( Nday == 0 ) then
319 : return
320 : endif
321 :
322 : ! Rearrange input arrays
323 0 : call CmpDayNite(E_pmid(:,pverp-rrtmg_levs+1:pver), pmid(:,1:rrtmg_levs-1), &
324 38400 : Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs-1)
325 : call CmpDayNite(E_cld(:,pverp-rrtmg_levs+1:pver), cld(:,1:rrtmg_levs-1), &
326 38400 : Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs-1)
327 :
328 38400 : call CmpDayNite(r_state%pintmb, pintmb, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs+1)
329 38400 : call CmpDayNite(r_state%pmidmb, pmidmb, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs)
330 38400 : call CmpDayNite(r_state%h2ovmr, h2ovmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs)
331 38400 : call CmpDayNite(r_state%o3vmr, o3vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs)
332 38400 : call CmpDayNite(r_state%co2vmr, co2vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs)
333 :
334 38400 : call CmpDayNite(E_coszrs, coszrs, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
335 38400 : call CmpDayNite(E_asdir, asdir, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
336 38400 : call CmpDayNite(E_aldir, aldir, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
337 38400 : call CmpDayNite(E_asdif, asdif, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
338 38400 : call CmpDayNite(E_aldif, aldif, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
339 :
340 38400 : call CmpDayNite(r_state%tlay, tlay, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs)
341 38400 : call CmpDayNite(r_state%tlev, tlev, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs+1)
342 38400 : call CmpDayNite(r_state%ch4vmr, ch4vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs)
343 38400 : call CmpDayNite(r_state%o2vmr, o2vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs)
344 38400 : call CmpDayNite(r_state%n2ovmr, n2ovmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs)
345 :
346 : ! These fields are no longer input by CAM.
347 20928000 : cicewp = 0.0_r8
348 20928000 : cliqwp = 0.0_r8
349 20928000 : rel = 0.0_r8
350 20928000 : rei = 0.0_r8
351 :
352 : ! Aerosol daylight map
353 : ! Also convert to optical properties of rrtmg interface, even though
354 : ! these quantities are later multiplied back together inside rrtmg !
355 : ! Why does rrtmg use the factored quantities?
356 : ! There are several different ways this factoring could be done.
357 : ! Other ways might allow for better optimization
358 576000 : do ns = 1, nbndsw
359 17779200 : do k = 1, rrtmg_levs-1
360 17203200 : kk=(pverp-rrtmg_levs) + k
361 141603840 : do i = 1, Nday
362 123863040 : if(E_aer_tau_w(IdxDay(i),kk,ns) > 1.e-80_r8) then
363 123863040 : asm_aer_sw(i,k,ns) = E_aer_tau_w_g(IdxDay(i),kk,ns)/E_aer_tau_w(IdxDay(i),kk,ns)
364 : else
365 0 : asm_aer_sw(i,k,ns) = 0._r8
366 : endif
367 141066240 : if(E_aer_tau(IdxDay(i),kk,ns) > 0._r8) then
368 123863040 : ssa_aer_sw(i,k,ns) = E_aer_tau_w(IdxDay(i),kk,ns)/E_aer_tau(IdxDay(i),kk,ns)
369 123863040 : tau_aer_sw(i,k,ns) = E_aer_tau(IdxDay(i),kk,ns)
370 : else
371 0 : ssa_aer_sw(i,k,ns) = 1._r8
372 0 : tau_aer_sw(i,k,ns) = 0._r8
373 : endif
374 : enddo
375 : enddo
376 : enddo
377 :
378 38400 : if (scm_crm_mode) then
379 : ! overwrite albedos for CRM
380 0 : if(have_asdir) asdir = asdirobs(1)
381 0 : if(have_asdif) asdif = asdifobs(1)
382 0 : if(have_aldir) aldir = aldirobs(1)
383 0 : if(have_aldif) aldif = aldifobs(1)
384 : endif
385 :
386 : ! Define solar incident radiation
387 314880 : do i = 1, Nday
388 4185600 : solin(i) = sum(sfac(:)*solar_band_irrad(:)) * eccf * coszrs(i)
389 : end do
390 :
391 : ! Calculate cloud optical properties here if using CAM method, or if using one of the
392 : ! methods in RRTMG_SW, then pass in cloud physical properties and zero out cloud optical
393 : ! properties here
394 :
395 : ! Zero optional cloud optical property input arrays tauc_sw, ssac_sw, asmc_sw,
396 : ! if inputting cloud physical properties to RRTMG_SW
397 : !tauc_sw(:,:,:) = 0.0_r8
398 : !ssac_sw(:,:,:) = 1.0_r8
399 : !asmc_sw(:,:,:) = 0.0_r8
400 : !fsfc_sw(:,:,:) = 0.0_r8
401 : !
402 : ! Or, calculate and pass in CAM cloud shortwave optical properties to RRTMG_SW
403 : !if (present(old_convert)) print *, 'old_convert',old_convert
404 : !if (present(ancientmethod)) print *, 'ancientmethod',ancientmethod
405 38400 : if (present(old_convert))then
406 38400 : if (old_convert)then ! convert without limits
407 0 : do i = 1, Nday
408 0 : do k = 1, rrtmg_levs-1
409 0 : kk=(pverp-rrtmg_levs) + k
410 0 : do ns = 1, nbndsw
411 0 : if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then
412 0 : fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/E_cld_tau_w(ns,IdxDay(i),kk)
413 0 : asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/E_cld_tau_w(ns,IdxDay(i),kk)
414 : else
415 0 : fsfc_sw(ns,i,k) = 0._r8
416 0 : asmc_sw(ns,i,k) = 0._r8
417 : endif
418 :
419 0 : tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk)
420 0 : if (tauc_sw(ns,i,k) > 0._r8) then
421 0 : ssac_sw(ns,i,k)=E_cld_tau_w(ns,IdxDay(i),kk)/tauc_sw(ns,i,k)
422 : else
423 0 : tauc_sw(ns,i,k) = 0._r8
424 0 : fsfc_sw(ns,i,k) = 0._r8
425 0 : asmc_sw(ns,i,k) = 0._r8
426 0 : ssac_sw(ns,i,k) = 1._r8
427 : endif
428 : enddo
429 : enddo
430 : enddo
431 : else
432 : ! eventually, when we are done with archaic versions, This set of code will become the default.
433 314880 : do i = 1, Nday
434 9162240 : do k = 1, rrtmg_levs-1
435 8847360 : kk=(pverp-rrtmg_levs) + k
436 132986880 : do ns = 1, nbndsw
437 123863040 : if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then
438 29633030 : fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8)
439 29633030 : asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8)
440 : else
441 94230010 : fsfc_sw(ns,i,k) = 0._r8
442 94230010 : asmc_sw(ns,i,k) = 0._r8
443 : endif
444 :
445 123863040 : tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk)
446 132710400 : if (tauc_sw(ns,i,k) > 0._r8) then
447 29633030 : ssac_sw(ns,i,k)=max(E_cld_tau_w(ns,IdxDay(i),kk),1.e-80_r8)/max(tauc_sw(ns,i,k),1.e-80_r8)
448 : else
449 94230010 : tauc_sw(ns,i,k) = 0._r8
450 94230010 : fsfc_sw(ns,i,k) = 0._r8
451 94230010 : asmc_sw(ns,i,k) = 0._r8
452 94230010 : ssac_sw(ns,i,k) = 1._r8
453 : endif
454 : enddo
455 : enddo
456 : enddo
457 : endif
458 : else
459 0 : do i = 1, Nday
460 0 : do k = 1, rrtmg_levs-1
461 0 : kk=(pverp-rrtmg_levs) + k
462 0 : do ns = 1, nbndsw
463 0 : if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then
464 0 : fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8)
465 0 : asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8)
466 : else
467 0 : fsfc_sw(ns,i,k) = 0._r8
468 0 : asmc_sw(ns,i,k) = 0._r8
469 : endif
470 :
471 0 : tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk)
472 0 : if (tauc_sw(ns,i,k) > 0._r8) then
473 0 : ssac_sw(ns,i,k)=max(E_cld_tau_w(ns,IdxDay(i),kk),1.e-80_r8)/max(tauc_sw(ns,i,k),1.e-80_r8)
474 : else
475 0 : tauc_sw(ns,i,k) = 0._r8
476 0 : fsfc_sw(ns,i,k) = 0._r8
477 0 : asmc_sw(ns,i,k) = 0._r8
478 0 : ssac_sw(ns,i,k) = 1._r8
479 : endif
480 : enddo
481 : enddo
482 : enddo
483 : endif
484 :
485 : ! Call mcica sub-column generator for RRTMG_SW
486 :
487 : ! Call sub-column generator for McICA in radiation
488 38400 : call t_startf('mcica_subcol_sw')
489 :
490 : ! Set permute seed (must be offset between LW and SW by at least 140 to insure
491 : ! effective randomization)
492 38400 : permuteseed = 1
493 :
494 :
495 : call mcica_subcol_sw(lchnk, Nday, rrtmg_levs-1, icld, permuteseed, pmid, &
496 : cld, cicewp, cliqwp, rei, rel, tauc_sw, ssac_sw, asmc_sw, fsfc_sw, &
497 : cld_stosw, cicewp_stosw, cliqwp_stosw, rei_stosw, rel_stosw, &
498 38400 : tauc_stosw, ssac_stosw, asmc_stosw, fsfc_stosw)
499 :
500 38400 : call t_stopf('mcica_subcol_sw')
501 :
502 38400 : call t_startf('rrtmg_sw')
503 :
504 : ! Call RRTMG_SW for all layers for daylight columns
505 :
506 :
507 : ! Set day of year for Earth/Sun distance calculation in rrtmg_sw, or
508 : ! set to zero and pass E/S adjustment (eccf) directly into array adjes
509 38400 : dyofyr = 0
510 :
511 591360 : tsfc(:ncol) = tlev(:ncol,rrtmg_levs+1)
512 :
513 38400 : solvar(1:nbndsw) = sfac(1:nbndsw)
514 :
515 : call rrtmg_sw(lchnk, Nday, rrtmg_levs, icld, &
516 : pmidmb, pintmb, tlay, tlev, tsfc, &
517 : h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, &
518 : asdir, asdif, aldir, aldif, &
519 : coszrs, eccf, dyofyr, solvar, &
520 : cld_stosw, tauc_stosw, ssac_stosw, asmc_stosw, fsfc_stosw, &
521 : cicewp_stosw, cliqwp_stosw, rei, rel, &
522 : tau_aer_sw, ssa_aer_sw, asm_aer_sw, &
523 : swuflx, swdflx, swhr, swuflxc, swdflxc, swhrc, &
524 38400 : dirdnuv, dirdnir, difdnuv, difdnir, ninflx, ninflxc, swuflxs, swdflxs)
525 :
526 : ! Flux units are in W/m2 on output from rrtmg_sw and contain output for
527 : ! extra layer above model top with vertical indexing from bottom to top.
528 : !
529 : ! Heating units are in J/kg/s on output from rrtmg_sw and contain output
530 : ! for extra layer above model top with vertical indexing from bottom to top.
531 : !
532 : ! Reverse vertical indexing to go from top to bottom for CAM output.
533 :
534 : ! Set the net absorted shortwave flux at TOA (top of extra layer)
535 314880 : fsntoa(1:Nday) = swdflx(1:Nday,rrtmg_levs+1) - swuflx(1:Nday,rrtmg_levs+1)
536 314880 : fsutoa(1:Nday) = swuflx(1:Nday,rrtmg_levs+1)
537 314880 : fsntoac(1:Nday) = swdflxc(1:Nday,rrtmg_levs+1) - swuflxc(1:Nday,rrtmg_levs+1)
538 :
539 : ! Set net near-IR flux at top of the model
540 314880 : fsnirtoa(1:Nday) = ninflx(1:Nday,rrtmg_levs)
541 314880 : fsnrtoaq(1:Nday) = ninflx(1:Nday,rrtmg_levs)
542 314880 : fsnrtoac(1:Nday) = ninflxc(1:Nday,rrtmg_levs)
543 :
544 : ! Set the net absorbed shortwave flux at the model top level
545 314880 : fsnt(1:Nday) = swdflx(1:Nday,rrtmg_levs) - swuflx(1:Nday,rrtmg_levs)
546 314880 : fsntc(1:Nday) = swdflxc(1:Nday,rrtmg_levs) - swuflxc(1:Nday,rrtmg_levs)
547 :
548 : ! Set the downwelling flux at the surface
549 314880 : fsds(1:Nday) = swdflx(1:Nday,1)
550 314880 : fsdsc(1:Nday) = swdflxc(1:Nday,1)
551 :
552 : ! Set the net shortwave flux at the surface
553 314880 : fsns(1:Nday) = swdflx(1:Nday,1) - swuflx(1:Nday,1)
554 314880 : fsnsc(1:Nday) = swdflxc(1:Nday,1) - swuflxc(1:Nday,1)
555 :
556 : ! Set the UV/vis and near-IR direct and dirruse downward shortwave flux at surface
557 314880 : sols(1:Nday) = dirdnuv(1:Nday,1)
558 314880 : soll(1:Nday) = dirdnir(1:Nday,1)
559 314880 : solsd(1:Nday) = difdnuv(1:Nday,1)
560 314880 : solld(1:Nday) = difdnir(1:Nday,1)
561 :
562 :
563 : ! Set the net, up and down fluxes at model interfaces
564 10429440 : fns (1:Nday,pverp-rrtmg_levs+1:pverp) = swdflx(1:Nday,rrtmg_levs:1:-1) - swuflx(1:Nday,rrtmg_levs:1:-1)
565 10429440 : fcns(1:Nday,pverp-rrtmg_levs+1:pverp) = swdflxc(1:Nday,rrtmg_levs:1:-1) - swuflxc(1:Nday,rrtmg_levs:1:-1)
566 10429440 : fus (1:Nday,pverp-rrtmg_levs+1:pverp) = swuflx(1:Nday,rrtmg_levs:1:-1)
567 10429440 : fusc(1:Nday,pverp-rrtmg_levs+1:pverp) = swuflxc(1:Nday,rrtmg_levs:1:-1)
568 10429440 : fds (1:Nday,pverp-rrtmg_levs+1:pverp) = swdflx(1:Nday,rrtmg_levs:1:-1)
569 10429440 : fdsc(1:Nday,pverp-rrtmg_levs+1:pverp) = swdflxc(1:Nday,rrtmg_levs:1:-1)
570 :
571 : ! Set solar heating, reverse layering
572 : ! Pass shortwave heating to CAM arrays and convert from K/d to J/kg/s
573 10114560 : qrs (1:Nday,pverp-rrtmg_levs+1:pver) = swhr (1:Nday,rrtmg_levs-1:1:-1)*cpair*dps
574 10114560 : qrsc(1:Nday,pverp-rrtmg_levs+1:pver) = swhrc(1:Nday,rrtmg_levs-1:1:-1)*cpair*dps
575 :
576 : ! Set spectral fluxes, reverse layering
577 : ! order=(/3,1,2/) maps the first index of swuflxs to the third index of su.
578 38400 : if (associated(su)) then
579 0 : su(1:Nday,pverp-rrtmg_levs+1:pverp,:) = reshape(swuflxs(:,1:Nday,rrtmg_levs:1:-1), &
580 0 : (/Nday,rrtmg_levs,nbndsw/), order=(/3,1,2/))
581 : end if
582 :
583 38400 : if (associated(sd)) then
584 0 : sd(1:Nday,pverp-rrtmg_levs+1:pverp,:) = reshape(swdflxs(:,1:Nday,rrtmg_levs:1:-1), &
585 0 : (/Nday,rrtmg_levs,nbndsw/), order=(/3,1,2/))
586 : end if
587 :
588 38400 : call t_stopf('rrtmg_sw')
589 :
590 : ! Rearrange output arrays.
591 : !
592 : ! intent(out)
593 :
594 38400 : call ExpDayNite(solin, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
595 38400 : call ExpDayNite(qrs, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pver)
596 38400 : call ExpDayNite(qrsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pver)
597 38400 : call ExpDayNite(fns, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp)
598 38400 : call ExpDayNite(fcns, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp)
599 38400 : call ExpDayNite(fsns, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
600 38400 : call ExpDayNite(fsnt, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
601 38400 : call ExpDayNite(fsntoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
602 38400 : call ExpDayNite(fsutoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
603 38400 : call ExpDayNite(fsds, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
604 38400 : call ExpDayNite(fsnsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
605 38400 : call ExpDayNite(fsdsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
606 38400 : call ExpDayNite(fsntc, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
607 38400 : call ExpDayNite(fsntoac, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
608 38400 : call ExpDayNite(sols, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
609 38400 : call ExpDayNite(soll, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
610 38400 : call ExpDayNite(solsd, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
611 38400 : call ExpDayNite(solld, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
612 38400 : call ExpDayNite(fsnirtoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
613 38400 : call ExpDayNite(fsnrtoac, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
614 38400 : call ExpDayNite(fsnrtoaq, Nday, IdxDay, Nnite, IdxNite, 1, pcols)
615 :
616 38400 : if (associated(su)) then
617 0 : call ExpDayNite(su, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp, 1, nbndsw)
618 : end if
619 :
620 38400 : if (associated(sd)) then
621 0 : call ExpDayNite(sd, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp, 1, nbndsw)
622 : end if
623 :
624 : ! these outfld calls don't work for spmd only outfield in scm mode (nonspmd)
625 38400 : if (single_column .and. scm_crm_mode) then
626 : ! Following outputs added for CRM
627 0 : call ExpDayNite(fus,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp)
628 0 : call ExpDayNite(fds,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp)
629 0 : call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp)
630 0 : call ExpDayNite(fdsc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp)
631 0 : call outfld('FUS ', fus, pcols, lchnk)
632 0 : call outfld('FDS ', fds, pcols, lchnk)
633 0 : call outfld('FUSC ', fusc, pcols, lchnk)
634 0 : call outfld('FDSC ', fdsc, pcols, lchnk)
635 : endif
636 :
637 38400 : end subroutine rad_rrtmg_sw
638 :
639 : !-------------------------------------------------------------------------------
640 :
641 1536 : subroutine radsw_init()
642 : !-----------------------------------------------------------------------
643 : !
644 : ! Purpose:
645 : ! Initialize various constants for radiation scheme.
646 : !
647 : !-----------------------------------------------------------------------
648 38400 : use radconstants, only: get_solar_band_fraction_irrad, get_ref_solar_band_irrad
649 :
650 : ! get the reference fractional solar irradiance in each band
651 1536 : call get_solar_band_fraction_irrad(fractional_solar_irradiance)
652 1536 : call get_ref_solar_band_irrad( solar_band_irrad )
653 :
654 :
655 : ! Initialize rrtmg_sw
656 1536 : call rrtmg_sw_ini
657 :
658 1536 : end subroutine radsw_init
659 :
660 :
661 : !-------------------------------------------------------------------------------
662 :
663 : end module radsw
|
