Line data Source code
1 : !=======================================================================
2 : !
3 : ! The albedo and absorbed/transmitted flux parameterizations for
4 : ! snow over ice, bare ice and ponded ice.
5 : !
6 : ! Presently, two methods are included:
7 : ! (1) CCSM3
8 : ! (2) Delta-Eddington
9 : ! as two distinct routines.
10 : ! Either can be called from the ice driver.
11 : !
12 : ! The Delta-Eddington method is described here:
13 : !
14 : ! Briegleb, B. P., and B. Light (2007): A Delta-Eddington Multiple
15 : ! Scattering Parameterization for Solar Radiation in the Sea Ice
16 : ! Component of the Community Climate System Model, NCAR Technical
17 : ! Note NCAR/TN-472+STR February 2007
18 : !
19 : ! name: originally ice_albedo
20 : !
21 : ! authors: Bruce P. Briegleb, NCAR
22 : ! Elizabeth C. Hunke and William H. Lipscomb, LANL
23 : ! 2005, WHL: Moved absorbed_solar from icepack_therm_vertical to this
24 : ! module and changed name from ice_albedo
25 : ! 2006, WHL: Added Delta Eddington routines from Bruce Briegleb
26 : ! 2006, ECH: Changed data statements in Delta Eddington routines (no
27 : ! longer hardwired)
28 : ! Converted to free source form (F90)
29 : ! 2007, BPB: Completely updated Delta-Eddington code, so that:
30 : ! (1) multiple snow layers enabled (i.e. nslyr > 1)
31 : ! (2) included SSL for snow surface absorption
32 : ! (3) added Sswabs for internal snow layer absorption
33 : ! (4) variable sea ice layers allowed (i.e. not hardwired)
34 : ! (5) updated all inherent optical properties
35 : ! (6) included algae absorption for sea ice lowest layer
36 : ! (7) very complete internal documentation included
37 : ! 2007, ECH: Improved efficiency
38 : ! 2008, BPB: Added aerosols to Delta Eddington code
39 : ! 2013, ECH: merged with NCAR version, cleaned up
40 :
41 : module icepack_shortwave
42 :
43 : use icepack_kinds
44 : use icepack_parameters, only: c0, c1, c1p5, c2, c3, c4, c10
45 : use icepack_parameters, only: p01, p1, p15, p25, p5, p75, puny
46 : use icepack_parameters, only: argcheck
47 : use icepack_parameters, only: albocn, Timelt, snowpatch, awtvdr, awtidr, awtvdf, awtidf
48 : use icepack_parameters, only: kappav, hs_min, rhofresh, rhos, rhoi
49 : use icepack_parameters, only: rsnw_fall, snwredist, rsnw_tmax
50 : use icepack_parameters, only: hi_ssl, hs_ssl, min_bgc, sk_l, snwlvlfac, snwgrain
51 : use icepack_parameters, only: z_tracers, skl_bgc, calc_tsfc, shortwave, kalg
52 : use icepack_parameters, only: R_ice, R_pnd, R_snw, dT_mlt, rsnw_mlt, hs0, hs1, hp1
53 : use icepack_parameters, only: pndaspect, albedo_type, albicev, albicei, albsnowv, albsnowi, ahmax
54 : use icepack_parameters, only: snw_ssp_table, modal_aero
55 : use icepack_parameters, only: dEdd_algae
56 :
57 : use icepack_tracers, only: ncat, nilyr, nslyr, nblyr
58 : use icepack_tracers, only: ntrcr, nbtrcr_sw
59 : use icepack_tracers, only: tr_pond_lvl, tr_pond_topo
60 : use icepack_tracers, only: tr_bgc_N, tr_aero
61 : use icepack_tracers, only: nt_bgc_N, nt_zaero
62 : use icepack_tracers, only: tr_zaero, nlt_chl_sw, nlt_zaero_sw
63 : use icepack_tracers, only: n_algae, n_aero, n_zaero
64 : use icepack_tracers, only: nmodal1, nmodal2, max_aero
65 : use icepack_shortwave_data, only: nspint_3bd, nspint_5bd
66 : use icepack_zbgc_shared,only: R_chl2N, F_abs_chl
67 : use icepack_zbgc_shared,only: remap_zbgc
68 : use icepack_orbital, only: compute_coszen
69 : use icepack_warnings, only: warnstr, icepack_warnings_add
70 : use icepack_warnings, only: icepack_warnings_setabort, icepack_warnings_aborted
71 :
72 : ! dEdd 3-band data
73 : use icepack_shortwave_data, only: &
74 : ! inherent optical properties (iop)
75 : ! k = extinction coefficient (/m)
76 : ! w = single scattering albedo
77 : ! g = asymmetry parameter
78 : ki_ssl_mn_3bd, wi_ssl_mn_3bd, gi_ssl_mn_3bd, & ! ice surface scattering layer (ssl) iops
79 : ki_dl_mn_3bd, wi_dl_mn_3bd, gi_dl_mn_3bd , & ! ice drained layer (dl) iops ! LCOV_EXCL_LINE
80 : ki_int_mn_3bd, wi_int_mn_3bd, gi_int_mn_3bd, & ! ice interior layer (int) iops ! LCOV_EXCL_LINE
81 : ki_p_ssl_mn, wi_p_ssl_mn, gi_p_ssl_mn , & ! ponded ice surface scattering layer (ssl) iops ! LCOV_EXCL_LINE
82 : ki_p_int_mn, wi_p_int_mn, gi_p_int_mn , & ! ponded ice interior layer (int) iops ! LCOV_EXCL_LINE
83 : kw, ww, gw ! iops for pond water and underlying ocean
84 : use icepack_shortwave_data, only: &
85 : gaer_bc_3bd, kaer_bc_3bd, waer_bc_3bd, bcenh_3bd, & ! LCOV_EXCL_LINE
86 : gaer_3bd, kaer_3bd, waer_3bd
87 : use icepack_shortwave_data, only: &
88 : nmbrad_snw, & ! number of snow grain radii in tables ! LCOV_EXCL_LINE
89 : rsnw_tab, & ! snow grain radii (micro-meters) for table ! LCOV_EXCL_LINE
90 : Qs_tab, & ! snow extinction efficiency (unitless) ! LCOV_EXCL_LINE
91 : ws_tab, & ! snow single scattering albedo (unitless) ! LCOV_EXCL_LINE
92 : gs_tab ! snow asymmetry parameter (unitless)
93 :
94 : ! dEdd 5-band data
95 : use icepack_shortwave_data, only: &
96 : ki_ssl_mn_5bd, wi_ssl_mn_5bd, gi_ssl_mn_5bd, & ! ice surface scattering layer (ssl) iops ! LCOV_EXCL_LINE
97 : ki_dl_mn_5bd, wi_dl_mn_5bd, gi_dl_mn_5bd , & ! ice drained layer (dl) iops ! LCOV_EXCL_LINE
98 : ki_int_mn_5bd, wi_int_mn_5bd, gi_int_mn_5bd ! ice interior layer (int) iops
99 : use icepack_shortwave_data, only: &
100 : gaer_bc_5bd, kaer_bc_5bd, waer_bc_5bd, bcenh_5bd, & ! LCOV_EXCL_LINE
101 : gaer_5bd, kaer_5bd, waer_5bd
102 : use icepack_shortwave_data, only: &
103 : nmbrad_snicar , & ! number of snow grain radii in SNICAR SSP tables ! LCOV_EXCL_LINE
104 : rsnw_snicar_min, & ! minimum snow radius - integer value used for indexing ! LCOV_EXCL_LINE
105 : rsnw_snicar_max ! maximum snow radius - integer value used for indexing
106 : use icepack_shortwave_data, only: &
107 : ssp_snwextdr, ssp_snwalbdr, ssp_sasymmdr, & ! LCOV_EXCL_LINE
108 : ssp_snwextdf, ssp_snwalbdf, ssp_sasymmdf, & ! LCOV_EXCL_LINE
109 : rsnw_snicar_tab
110 :
111 : implicit none
112 :
113 : private
114 : public :: icepack_prep_radiation, &
115 : icepack_init_radiation, & ! LCOV_EXCL_LINE
116 : icepack_step_radiation
117 :
118 : real (kind=dbl_kind), parameter :: &
119 : hpmin = 0.005_dbl_kind, & ! minimum allowed melt pond depth (m) ! LCOV_EXCL_LINE
120 : hp0 = 0.200_dbl_kind ! pond depth below which transition to bare ice
121 :
122 : real (kind=dbl_kind), parameter :: &
123 : exp_argmax = c10 ! maximum argument of exponential
124 :
125 : ! dEdd tuning parameters, set in namelist
126 : ! R_ice ! sea ice tuning parameter; +1 > 1sig increase in albedo
127 : ! R_pnd ! ponded ice tuning parameter; +1 > 1sig increase in albedo
128 : ! R_snw ! snow tuning parameter; +1 > ~.01 change in broadband albedo
129 : ! dT_mlt ! change in temp for non-melt to melt snow grain radius change (C)
130 : ! rsnw_mlt ! maximum melting snow grain radius (10^-6 m)
131 : ! pndaspect ! ratio of pond depth to pond fraction
132 : ! hs0 ! snow depth for transition to bare sea ice (m)
133 : ! hs1 ! tapering parameter for snow on pond ice
134 : ! hp1 ! critical parameter for pond ice thickness
135 : ! kalg ! algae absorption coefficient
136 :
137 : !=======================================================================
138 :
139 : contains
140 :
141 : !=======================================================================
142 : !autodocument_start icepack_init_radiation
143 : ! Initialize data needed for shortwave radiation calculations
144 : ! This should be called after values are set via icepack_init_parameters
145 :
146 37 : subroutine icepack_init_radiation()
147 :
148 : !autodocument_end
149 : use icepack_shortwave_data, only: icepack_shortwave_init_dEdd3band
150 : use icepack_shortwave_data, only: icepack_shortwave_init_dEdd5band
151 : use icepack_shortwave_data, only: icepack_shortwave_init_snicar
152 : use icepack_shortwave_data, only: icepack_shortwave_init_snicartest
153 :
154 : ! local variables
155 :
156 : integer (kind=int_kind) :: n
157 :
158 : character (len=*),parameter :: subname='(icepack_init_radiation)'
159 :
160 : !-----------------------------------------------------------------
161 : ! Set dEdd parameter tables
162 : !-----------------------------------------------------------------
163 :
164 37 : if (shortwave(1:4) == 'dEdd') then
165 37 : call icepack_shortwave_init_dEdd3band()
166 37 : if (icepack_warnings_aborted(subname)) return
167 : endif
168 :
169 37 : if (trim(shortwave) == 'dEdd_snicar_ad') then
170 0 : call icepack_shortwave_init_dEdd5band()
171 0 : if (icepack_warnings_aborted(subname)) return
172 :
173 0 : if (trim(snw_ssp_table) == 'test') then ! 5x5 test table
174 0 : call icepack_shortwave_init_snicartest()
175 0 : if (icepack_warnings_aborted(subname)) return
176 0 : elseif (trim(snw_ssp_table) == 'snicar') then ! 5 x 1471 table
177 0 : call icepack_shortwave_init_snicar()
178 0 : if (icepack_warnings_aborted(subname)) return
179 : else
180 0 : call icepack_warnings_setabort(.true.,__FILE__,__LINE__)
181 0 : call icepack_warnings_add(subname//'ERROR: snw_ssp_table = '//trim(snw_ssp_table)//' not supported')
182 0 : return
183 : endif
184 :
185 : !------------------------------
186 : ! Check SNICAR SSP data
187 : !------------------------------
188 :
189 0 : write(warnstr,'(2a,i8)') subname, ' nmbrad_snicar = ',nmbrad_snicar
190 0 : call icepack_warnings_add(warnstr)
191 0 : write(warnstr,'(2a,i8)') subname, ' nspint = ',nspint_5bd
192 0 : call icepack_warnings_add(warnstr)
193 0 : write(warnstr,'(2a,i8)') subname, ' nmodal1 = ',nmodal1
194 0 : call icepack_warnings_add(warnstr)
195 0 : write(warnstr,'(2a,i8)') subname, ' nmodal2 = ',nmodal2
196 0 : call icepack_warnings_add(warnstr)
197 0 : write(warnstr,'(2a,i8)') subname, ' max_aero = ',max_aero
198 0 : call icepack_warnings_add(warnstr)
199 0 : write(warnstr,'(2a,i5,a,i5,a,g22.15)') subname, ' ssp_snwextdr(',1, ',',1, ') = ',ssp_snwextdr(1,1)
200 0 : call icepack_warnings_add(warnstr)
201 0 : write(warnstr,'(2a,i5,a,i5,a,g22.15)') subname, ' ssp_snwextdr(',nspint_5bd,',',1, ') = ',ssp_snwextdr(nspint_5bd,1)
202 0 : call icepack_warnings_add(warnstr)
203 0 : write(warnstr,'(2a,i5,a,i5,a,g22.15)') subname, ' ssp_snwextdr(',1, ',',nmbrad_snicar,') = ',ssp_snwextdr(1,nmbrad_snicar)
204 0 : call icepack_warnings_add(warnstr)
205 0 : write(warnstr,'(2a,i5,a,i5,a,g22.15)') subname, ' ssp_snwextdr(',nspint_5bd,',',nmbrad_snicar,') = ',ssp_snwextdr(nspint_5bd,nmbrad_snicar)
206 0 : call icepack_warnings_add(warnstr)
207 :
208 : endif
209 :
210 : end subroutine icepack_init_radiation
211 :
212 : !=======================================================================
213 : !
214 : ! Driver for basic solar radiation from CCSM3. Albedos and absorbed solar.
215 :
216 0 : subroutine shortwave_ccsm3 (aicen, vicen, &
217 : vsnon, Tsfcn, & ! LCOV_EXCL_LINE
218 : swvdr, swvdf, & ! LCOV_EXCL_LINE
219 : swidr, swidf, & ! LCOV_EXCL_LINE
220 : albedo_type, & ! LCOV_EXCL_LINE
221 : albicev, albicei, & ! LCOV_EXCL_LINE
222 : albsnowv, albsnowi, & ! LCOV_EXCL_LINE
223 : ahmax, & ! LCOV_EXCL_LINE
224 : alvdrn, alidrn, & ! LCOV_EXCL_LINE
225 : alvdfn, alidfn, & ! LCOV_EXCL_LINE
226 : fswsfc, fswint, & ! LCOV_EXCL_LINE
227 : fswthrun, & ! LCOV_EXCL_LINE
228 : fswthrun_vdr, & ! LCOV_EXCL_LINE
229 : fswthrun_vdf, & ! LCOV_EXCL_LINE
230 : fswthrun_idr, & ! LCOV_EXCL_LINE
231 : fswthrun_idf, & ! LCOV_EXCL_LINE
232 : fswpenl, & ! LCOV_EXCL_LINE
233 : Iswabs, SSwabs, & ! LCOV_EXCL_LINE
234 : albin, albsn, & ! LCOV_EXCL_LINE
235 : coszen)
236 :
237 : real (kind=dbl_kind), dimension (:), intent(in) :: &
238 : aicen , & ! concentration of ice per category ! LCOV_EXCL_LINE
239 : vicen , & ! volume of ice per category ! LCOV_EXCL_LINE
240 : vsnon , & ! volume of ice per category ! LCOV_EXCL_LINE
241 : Tsfcn ! surface temperature
242 :
243 : real (kind=dbl_kind), intent(in) :: &
244 : swvdr , & ! sw down, visible, direct (W/m^2) ! LCOV_EXCL_LINE
245 : swvdf , & ! sw down, visible, diffuse (W/m^2) ! LCOV_EXCL_LINE
246 : swidr , & ! sw down, near IR, direct (W/m^2) ! LCOV_EXCL_LINE
247 : swidf ! sw down, near IR, diffuse (W/m^2)
248 :
249 : ! baseline albedos for ccsm3 shortwave, set in namelist
250 : real (kind=dbl_kind), intent(in) :: &
251 : albicev , & ! visible ice albedo for h > ahmax ! LCOV_EXCL_LINE
252 : albicei , & ! near-ir ice albedo for h > ahmax ! LCOV_EXCL_LINE
253 : albsnowv, & ! cold snow albedo, visible ! LCOV_EXCL_LINE
254 : albsnowi, & ! cold snow albedo, near IR ! LCOV_EXCL_LINE
255 : ahmax ! thickness above which ice albedo is constant (m)
256 :
257 : character (len=char_len), intent(in) :: &
258 : albedo_type ! albedo parameterization, 'ccsm3' or 'constant'
259 :
260 : real (kind=dbl_kind), dimension (:), intent(inout) :: &
261 : alvdrn , & ! visible, direct, avg (fraction) ! LCOV_EXCL_LINE
262 : alidrn , & ! near-ir, direct, avg (fraction) ! LCOV_EXCL_LINE
263 : alvdfn , & ! visible, diffuse, avg (fraction) ! LCOV_EXCL_LINE
264 : alidfn , & ! near-ir, diffuse, avg (fraction) ! LCOV_EXCL_LINE
265 : fswsfc , & ! SW absorbed at ice/snow surface (W m-2) ! LCOV_EXCL_LINE
266 : fswint , & ! SW absorbed in ice interior, below surface (W m-2) ! LCOV_EXCL_LINE
267 : fswthrun , & ! SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
268 : albin , & ! bare ice albedo ! LCOV_EXCL_LINE
269 : albsn ! snow albedo
270 :
271 : real (kind=dbl_kind), dimension (:), intent(out), optional :: &
272 : fswthrun_vdr, & ! vis dir SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
273 : fswthrun_vdf, & ! vis dif SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
274 : fswthrun_idr, & ! nir dir SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
275 : fswthrun_idf ! nir dif SW through ice to ocean (W m-2)
276 :
277 : real (kind=dbl_kind), intent(inout) :: &
278 : coszen ! cosine(zenith angle)
279 :
280 : real (kind=dbl_kind), dimension (:,:), intent(inout) :: &
281 : fswpenl , & ! SW entering ice layers (W m-2) ! LCOV_EXCL_LINE
282 : Iswabs , & ! SW absorbed in particular layer (W m-2) ! LCOV_EXCL_LINE
283 : Sswabs ! SW absorbed in particular layer (W m-2)
284 :
285 : ! local variables
286 :
287 : integer (kind=int_kind) :: &
288 : n ! thickness category index
289 :
290 : ! ice and snow albedo for each category
291 :
292 : real (kind=dbl_kind) :: &
293 : alvdrni, & ! visible, direct, ice (fraction) ! LCOV_EXCL_LINE
294 : alidrni, & ! near-ir, direct, ice (fraction) ! LCOV_EXCL_LINE
295 : alvdfni, & ! visible, diffuse, ice (fraction) ! LCOV_EXCL_LINE
296 : alidfni, & ! near-ir, diffuse, ice (fraction) ! LCOV_EXCL_LINE
297 : alvdrns, & ! visible, direct, snow (fraction) ! LCOV_EXCL_LINE
298 : alidrns, & ! near-ir, direct, snow (fraction) ! LCOV_EXCL_LINE
299 : alvdfns, & ! visible, diffuse, snow (fraction) ! LCOV_EXCL_LINE
300 0 : alidfns ! near-ir, diffuse, snow (fraction)
301 :
302 : ! needed for optional fswthrun arrays when passed as scalars
303 : real (kind=dbl_kind) :: &
304 : l_fswthru_vdr, & ! vis dir SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
305 : l_fswthru_vdf, & ! vis dif SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
306 : l_fswthru_idr, & ! nir dir SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
307 0 : l_fswthru_idf ! nir dif SW through ice to ocean (W m-2)
308 :
309 : character(len=*),parameter :: subname='(shortwave_ccsm3)'
310 :
311 : !-----------------------------------------------------------------
312 : ! Solar radiation: albedo and absorbed shortwave
313 : !-----------------------------------------------------------------
314 :
315 : ! For basic shortwave, set coszen to a constant between 0 and 1.
316 0 : coszen = p5 ! sun above the horizon
317 :
318 0 : do n = 1, ncat
319 :
320 0 : Sswabs(:,n) = c0
321 :
322 0 : alvdrni = albocn
323 0 : alidrni = albocn
324 0 : alvdfni = albocn
325 0 : alidfni = albocn
326 :
327 0 : alvdrns = albocn
328 0 : alidrns = albocn
329 0 : alvdfns = albocn
330 0 : alidfns = albocn
331 :
332 0 : alvdrn(n) = albocn
333 0 : alidrn(n) = albocn
334 0 : alvdfn(n) = albocn
335 0 : alidfn(n) = albocn
336 :
337 0 : albin(n) = c0
338 0 : albsn(n) = c0
339 :
340 0 : fswsfc(n) = c0
341 0 : fswint(n) = c0
342 0 : fswthrun(n) = c0
343 0 : fswpenl(:,n) = c0
344 0 : Iswabs (:,n) = c0
345 :
346 0 : if (aicen(n) > puny) then
347 :
348 : !-----------------------------------------------------------------
349 : ! Compute albedos for ice and snow.
350 : !-----------------------------------------------------------------
351 :
352 0 : if (trim(albedo_type) == 'constant') then
353 :
354 0 : call constant_albedos (aicen(n), &
355 : vsnon(n), & ! LCOV_EXCL_LINE
356 : Tsfcn(n), & ! LCOV_EXCL_LINE
357 : alvdrni, alidrni, & ! LCOV_EXCL_LINE
358 : alvdfni, alidfni, & ! LCOV_EXCL_LINE
359 : alvdrns, alidrns, & ! LCOV_EXCL_LINE
360 : alvdfns, alidfns, & ! LCOV_EXCL_LINE
361 : alvdrn(n), & ! LCOV_EXCL_LINE
362 : alidrn(n), & ! LCOV_EXCL_LINE
363 : alvdfn(n), & ! LCOV_EXCL_LINE
364 : alidfn(n), & ! LCOV_EXCL_LINE
365 : albin(n), & ! LCOV_EXCL_LINE
366 0 : albsn(n))
367 0 : if (icepack_warnings_aborted(subname)) return
368 :
369 0 : elseif (trim(albedo_type) == 'ccsm3') then
370 :
371 0 : call compute_albedos (aicen(n), &
372 : vicen(n), & ! LCOV_EXCL_LINE
373 : vsnon(n), & ! LCOV_EXCL_LINE
374 : Tsfcn(n), & ! LCOV_EXCL_LINE
375 : albicev, albicei, & ! LCOV_EXCL_LINE
376 : albsnowv, albsnowi, & ! LCOV_EXCL_LINE
377 : ahmax, & ! LCOV_EXCL_LINE
378 : alvdrni, alidrni, & ! LCOV_EXCL_LINE
379 : alvdfni, alidfni, & ! LCOV_EXCL_LINE
380 : alvdrns, alidrns, & ! LCOV_EXCL_LINE
381 : alvdfns, alidfns, & ! LCOV_EXCL_LINE
382 : alvdrn(n), & ! LCOV_EXCL_LINE
383 : alidrn(n), & ! LCOV_EXCL_LINE
384 : alvdfn(n), & ! LCOV_EXCL_LINE
385 : alidfn(n), & ! LCOV_EXCL_LINE
386 : albin(n), & ! LCOV_EXCL_LINE
387 0 : albsn(n))
388 0 : if (icepack_warnings_aborted(subname)) return
389 :
390 : else
391 :
392 0 : call icepack_warnings_add(subname//' ERROR: albedo_type '//trim(albedo_type)//' unknown')
393 0 : call icepack_warnings_setabort(.true.,__FILE__,__LINE__)
394 0 : return
395 :
396 : endif
397 :
398 : !-----------------------------------------------------------------
399 : ! Compute solar radiation absorbed in ice and penetrating to ocean.
400 : !-----------------------------------------------------------------
401 :
402 0 : call absorbed_solar (aicen(n), &
403 : vicen(n), & ! LCOV_EXCL_LINE
404 : vsnon(n), & ! LCOV_EXCL_LINE
405 : swvdr, swvdf, & ! LCOV_EXCL_LINE
406 : swidr, swidf, & ! LCOV_EXCL_LINE
407 : alvdrni, alvdfni, & ! LCOV_EXCL_LINE
408 : alidrni, alidfni, & ! LCOV_EXCL_LINE
409 : alvdrns, alvdfns, & ! LCOV_EXCL_LINE
410 : alidrns, alidfns, & ! LCOV_EXCL_LINE
411 : fswsfc=fswsfc(n), & ! LCOV_EXCL_LINE
412 : fswint=fswint(n), & ! LCOV_EXCL_LINE
413 : fswthru=fswthrun(n), & ! LCOV_EXCL_LINE
414 : fswthru_vdr=l_fswthru_vdr, & ! LCOV_EXCL_LINE
415 : fswthru_vdf=l_fswthru_vdf, & ! LCOV_EXCL_LINE
416 : fswthru_idr=l_fswthru_idr, & ! LCOV_EXCL_LINE
417 : fswthru_idf=l_fswthru_idf, & ! LCOV_EXCL_LINE
418 : fswpenl=fswpenl(:,n), & ! LCOV_EXCL_LINE
419 0 : Iswabs=Iswabs(:,n))
420 :
421 0 : if (icepack_warnings_aborted(subname)) return
422 :
423 0 : if (present(fswthrun_vdr)) fswthrun_vdr(n) = l_fswthru_vdr
424 0 : if (present(fswthrun_vdf)) fswthrun_vdf(n) = l_fswthru_vdf
425 0 : if (present(fswthrun_idr)) fswthrun_idr(n) = l_fswthru_idr
426 0 : if (present(fswthrun_idf)) fswthrun_idf(n) = l_fswthru_idf
427 :
428 : endif ! aicen > puny
429 :
430 : enddo ! ncat
431 :
432 : end subroutine shortwave_ccsm3
433 :
434 : !=======================================================================
435 : !
436 : ! Compute albedos for each thickness category
437 :
438 0 : subroutine compute_albedos (aicen, vicen, &
439 : vsnon, Tsfcn, & ! LCOV_EXCL_LINE
440 : albicev, albicei, & ! LCOV_EXCL_LINE
441 : albsnowv, albsnowi, & ! LCOV_EXCL_LINE
442 : ahmax, & ! LCOV_EXCL_LINE
443 : alvdrni, alidrni, & ! LCOV_EXCL_LINE
444 : alvdfni, alidfni, & ! LCOV_EXCL_LINE
445 : alvdrns, alidrns, & ! LCOV_EXCL_LINE
446 : alvdfns, alidfns, & ! LCOV_EXCL_LINE
447 : alvdrn, alidrn, & ! LCOV_EXCL_LINE
448 : alvdfn, alidfn, & ! LCOV_EXCL_LINE
449 : albin, albsn)
450 :
451 : real (kind=dbl_kind), intent(in) :: &
452 : aicen , & ! concentration of ice per category ! LCOV_EXCL_LINE
453 : vicen , & ! volume of ice per category ! LCOV_EXCL_LINE
454 : vsnon , & ! volume of ice per category ! LCOV_EXCL_LINE
455 : Tsfcn ! surface temperature
456 :
457 : ! baseline albedos for ccsm3 shortwave, set in namelist
458 : real (kind=dbl_kind), intent(in) :: &
459 : albicev , & ! visible ice albedo for h > ahmax ! LCOV_EXCL_LINE
460 : albicei , & ! near-ir ice albedo for h > ahmax ! LCOV_EXCL_LINE
461 : albsnowv, & ! cold snow albedo, visible ! LCOV_EXCL_LINE
462 : albsnowi, & ! cold snow albedo, near IR ! LCOV_EXCL_LINE
463 : ahmax ! thickness above which ice albedo is constant (m)
464 :
465 : real (kind=dbl_kind), intent(out) :: &
466 : alvdrni , & ! visible, direct, ice (fraction) ! LCOV_EXCL_LINE
467 : alidrni , & ! near-ir, direct, ice (fraction) ! LCOV_EXCL_LINE
468 : alvdfni , & ! visible, diffuse, ice (fraction) ! LCOV_EXCL_LINE
469 : alidfni , & ! near-ir, diffuse, ice (fraction) ! LCOV_EXCL_LINE
470 : alvdrns , & ! visible, direct, snow (fraction) ! LCOV_EXCL_LINE
471 : alidrns , & ! near-ir, direct, snow (fraction) ! LCOV_EXCL_LINE
472 : alvdfns , & ! visible, diffuse, snow (fraction) ! LCOV_EXCL_LINE
473 : alidfns , & ! near-ir, diffuse, snow (fraction) ! LCOV_EXCL_LINE
474 : alvdrn , & ! visible, direct, avg (fraction) ! LCOV_EXCL_LINE
475 : alidrn , & ! near-ir, direct, avg (fraction) ! LCOV_EXCL_LINE
476 : alvdfn , & ! visible, diffuse, avg (fraction) ! LCOV_EXCL_LINE
477 : alidfn , & ! near-ir, diffuse, avg (fraction) ! LCOV_EXCL_LINE
478 : albin , & ! bare ice ! LCOV_EXCL_LINE
479 : albsn ! snow
480 :
481 : ! local variables
482 :
483 : real (kind=dbl_kind), parameter :: &
484 : dT_melt = c1 , & ! change in temp to give dalb_mlt ! LCOV_EXCL_LINE
485 : ! albedo change
486 : dalb_mlt = -0.075_dbl_kind, & ! albedo change per dT_melt change
487 : ! in temp for ice
488 : dalb_mltv = -p1 , & ! albedo vis change per dT_melt change
489 : ! in temp for snow
490 : dalb_mlti = -p15 ! albedo nir change per dT_melt change
491 : ! in temp for snow
492 :
493 : real (kind=dbl_kind) :: &
494 : hi , & ! ice thickness (m) ! LCOV_EXCL_LINE
495 : hs , & ! snow thickness (m) ! LCOV_EXCL_LINE
496 : albo, & ! effective ocean albedo, function of ice thickness ! LCOV_EXCL_LINE
497 : fh , & ! piecewise linear function of thickness ! LCOV_EXCL_LINE
498 : fT , & ! piecewise linear function of surface temperature ! LCOV_EXCL_LINE
499 : dTs , & ! difference of Tsfc and Timelt ! LCOV_EXCL_LINE
500 : fhtan,& ! factor used in albedo dependence on ice thickness ! LCOV_EXCL_LINE
501 0 : asnow ! fractional area of snow cover
502 :
503 : character(len=*),parameter :: subname='(compute_albedos)'
504 :
505 : !-----------------------------------------------------------------
506 : ! Compute albedo for each thickness category.
507 : !-----------------------------------------------------------------
508 :
509 0 : hi = vicen / aicen
510 0 : hs = vsnon / aicen
511 :
512 : ! bare ice, thickness dependence
513 0 : fhtan = atan(ahmax*c4)
514 0 : fh = min(atan(hi*c4)/fhtan,c1)
515 0 : albo = albocn*(c1-fh)
516 0 : alvdfni = albicev*fh + albo
517 0 : alidfni = albicei*fh + albo
518 :
519 : ! bare ice, temperature dependence
520 0 : dTs = Timelt - Tsfcn
521 0 : fT = min(dTs/dT_melt-c1,c0)
522 0 : alvdfni = alvdfni - dalb_mlt*fT
523 0 : alidfni = alidfni - dalb_mlt*fT
524 :
525 : ! avoid negative albedos for thin, bare, melting ice
526 0 : alvdfni = max (alvdfni, albocn)
527 0 : alidfni = max (alidfni, albocn)
528 :
529 0 : if (hs > puny) then
530 :
531 0 : alvdfns = albsnowv
532 0 : alidfns = albsnowi
533 :
534 : ! snow on ice, temperature dependence
535 0 : alvdfns = alvdfns - dalb_mltv*fT
536 0 : alidfns = alidfns - dalb_mlti*fT
537 :
538 : endif ! hs > puny
539 :
540 : ! direct albedos (same as diffuse for now)
541 0 : alvdrni = alvdfni
542 0 : alidrni = alidfni
543 0 : alvdrns = alvdfns
544 0 : alidrns = alidfns
545 :
546 : ! fractional area of snow cover
547 0 : if (hs > puny) then
548 0 : asnow = hs / (hs + snowpatch)
549 : else
550 0 : asnow = c0
551 : endif
552 :
553 : ! combine ice and snow albedos (for coupler)
554 : alvdfn = alvdfni*(c1-asnow) + &
555 0 : alvdfns*asnow
556 : alidfn = alidfni*(c1-asnow) + &
557 0 : alidfns*asnow
558 : alvdrn = alvdrni*(c1-asnow) + &
559 0 : alvdrns*asnow
560 : alidrn = alidrni*(c1-asnow) + &
561 0 : alidrns*asnow
562 :
563 : ! save ice and snow albedos (for history)
564 : albin = awtvdr*alvdrni + awtidr*alidrni &
565 0 : + awtvdf*alvdfni + awtidf*alidfni
566 : albsn = awtvdr*alvdrns + awtidr*alidrns &
567 0 : + awtvdf*alvdfns + awtidf*alidfns
568 :
569 0 : end subroutine compute_albedos
570 :
571 : !=======================================================================
572 : !
573 : ! Compute albedos for each thickness category
574 :
575 0 : subroutine constant_albedos (aicen, &
576 : vsnon, Tsfcn, & ! LCOV_EXCL_LINE
577 : alvdrni, alidrni, & ! LCOV_EXCL_LINE
578 : alvdfni, alidfni, & ! LCOV_EXCL_LINE
579 : alvdrns, alidrns, & ! LCOV_EXCL_LINE
580 : alvdfns, alidfns, & ! LCOV_EXCL_LINE
581 : alvdrn, alidrn, & ! LCOV_EXCL_LINE
582 : alvdfn, alidfn, & ! LCOV_EXCL_LINE
583 : albin, albsn)
584 :
585 : real (kind=dbl_kind), intent(in) :: &
586 : aicen , & ! concentration of ice per category ! LCOV_EXCL_LINE
587 : vsnon , & ! volume of ice per category ! LCOV_EXCL_LINE
588 : Tsfcn ! surface temperature
589 :
590 : real (kind=dbl_kind), intent(out) :: &
591 : alvdrni , & ! visible, direct, ice (fraction) ! LCOV_EXCL_LINE
592 : alidrni , & ! near-ir, direct, ice (fraction) ! LCOV_EXCL_LINE
593 : alvdfni , & ! visible, diffuse, ice (fraction) ! LCOV_EXCL_LINE
594 : alidfni , & ! near-ir, diffuse, ice (fraction) ! LCOV_EXCL_LINE
595 : alvdrns , & ! visible, direct, snow (fraction) ! LCOV_EXCL_LINE
596 : alidrns , & ! near-ir, direct, snow (fraction) ! LCOV_EXCL_LINE
597 : alvdfns , & ! visible, diffuse, snow (fraction) ! LCOV_EXCL_LINE
598 : alidfns , & ! near-ir, diffuse, snow (fraction) ! LCOV_EXCL_LINE
599 : alvdrn , & ! visible, direct, avg (fraction) ! LCOV_EXCL_LINE
600 : alidrn , & ! near-ir, direct, avg (fraction) ! LCOV_EXCL_LINE
601 : alvdfn , & ! visible, diffuse, avg (fraction) ! LCOV_EXCL_LINE
602 : alidfn , & ! near-ir, diffuse, avg (fraction) ! LCOV_EXCL_LINE
603 : albin , & ! bare ice ! LCOV_EXCL_LINE
604 : albsn ! snow
605 :
606 : ! local variables
607 :
608 : real (kind=dbl_kind), parameter :: &
609 : warmice = 0.68_dbl_kind, & ! LCOV_EXCL_LINE
610 : coldice = 0.70_dbl_kind, & ! LCOV_EXCL_LINE
611 : warmsnow = 0.77_dbl_kind, & ! LCOV_EXCL_LINE
612 : coldsnow = 0.81_dbl_kind
613 :
614 : real (kind=dbl_kind) :: &
615 0 : hs ! snow thickness (m)
616 :
617 : character(len=*),parameter :: subname='(constant_albedos)'
618 :
619 : !-----------------------------------------------------------------
620 : ! Compute albedo for each thickness category.
621 : !-----------------------------------------------------------------
622 :
623 0 : hs = vsnon / aicen
624 :
625 0 : if (hs > puny) then
626 : ! snow, temperature dependence
627 0 : if (Tsfcn >= -c2*puny) then
628 0 : alvdfn = warmsnow
629 0 : alidfn = warmsnow
630 : else
631 0 : alvdfn = coldsnow
632 0 : alidfn = coldsnow
633 : endif
634 : else ! hs < puny
635 : ! bare ice, temperature dependence
636 0 : if (Tsfcn >= -c2*puny) then
637 0 : alvdfn = warmice
638 0 : alidfn = warmice
639 : else
640 0 : alvdfn = coldice
641 0 : alidfn = coldice
642 : endif
643 : endif ! hs > puny
644 :
645 : ! direct albedos (same as diffuse for now)
646 0 : alvdrn = alvdfn
647 0 : alidrn = alidfn
648 :
649 0 : alvdrni = alvdrn
650 0 : alidrni = alidrn
651 0 : alvdrns = alvdrn
652 0 : alidrns = alidrn
653 0 : alvdfni = alvdfn
654 0 : alidfni = alidfn
655 0 : alvdfns = alvdfn
656 0 : alidfns = alidfn
657 :
658 : ! save ice and snow albedos (for history)
659 : albin = awtvdr*alvdrni + awtidr*alidrni &
660 0 : + awtvdf*alvdfni + awtidf*alidfni
661 : albsn = awtvdr*alvdrns + awtidr*alidrns &
662 0 : + awtvdf*alvdfns + awtidf*alidfns
663 :
664 0 : end subroutine constant_albedos
665 :
666 : !=======================================================================
667 : !
668 : ! Compute solar radiation absorbed in ice and penetrating to ocean
669 : !
670 : ! authors William H. Lipscomb, LANL
671 : ! C. M. Bitz, UW
672 :
673 0 : subroutine absorbed_solar (aicen, &
674 : vicen, vsnon, & ! LCOV_EXCL_LINE
675 : swvdr, swvdf, & ! LCOV_EXCL_LINE
676 : swidr, swidf, & ! LCOV_EXCL_LINE
677 : alvdrni, alvdfni, & ! LCOV_EXCL_LINE
678 : alidrni, alidfni, & ! LCOV_EXCL_LINE
679 : alvdrns, alvdfns, & ! LCOV_EXCL_LINE
680 : alidrns, alidfns, & ! LCOV_EXCL_LINE
681 : fswsfc, fswint, & ! LCOV_EXCL_LINE
682 : fswthru, & ! LCOV_EXCL_LINE
683 : fswthru_vdr, & ! LCOV_EXCL_LINE
684 : fswthru_vdf, & ! LCOV_EXCL_LINE
685 : fswthru_idr, & ! LCOV_EXCL_LINE
686 : fswthru_idf, & ! LCOV_EXCL_LINE
687 : fswpenl, & ! LCOV_EXCL_LINE
688 0 : Iswabs)
689 :
690 : real (kind=dbl_kind), intent(in) :: &
691 : aicen , & ! fractional ice area ! LCOV_EXCL_LINE
692 : vicen , & ! ice volume ! LCOV_EXCL_LINE
693 : vsnon , & ! snow volume ! LCOV_EXCL_LINE
694 : swvdr , & ! sw down, visible, direct (W/m^2) ! LCOV_EXCL_LINE
695 : swvdf , & ! sw down, visible, diffuse (W/m^2) ! LCOV_EXCL_LINE
696 : swidr , & ! sw down, near IR, direct (W/m^2) ! LCOV_EXCL_LINE
697 : swidf , & ! sw down, near IR, diffuse (W/m^2) ! LCOV_EXCL_LINE
698 : alvdrni , & ! visible, direct albedo,ice ! LCOV_EXCL_LINE
699 : alidrni , & ! near-ir, direct albedo,ice ! LCOV_EXCL_LINE
700 : alvdfni , & ! visible, diffuse albedo,ice ! LCOV_EXCL_LINE
701 : alidfni , & ! near-ir, diffuse albedo,ice ! LCOV_EXCL_LINE
702 : alvdrns , & ! visible, direct albedo, snow ! LCOV_EXCL_LINE
703 : alidrns , & ! near-ir, direct albedo, snow ! LCOV_EXCL_LINE
704 : alvdfns , & ! visible, diffuse albedo, snow ! LCOV_EXCL_LINE
705 : alidfns ! near-ir, diffuse albedo, snow
706 :
707 : real (kind=dbl_kind), intent(out):: &
708 : fswsfc , & ! SW absorbed at ice/snow surface (W m-2) ! LCOV_EXCL_LINE
709 : fswint , & ! SW absorbed in ice interior, below surface (W m-2) ! LCOV_EXCL_LINE
710 : fswthru ! SW through ice to ocean (W m-2)
711 :
712 : real (kind=dbl_kind), intent(out) :: &
713 : fswthru_vdr , & ! vis dir SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
714 : fswthru_vdf , & ! vis dif SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
715 : fswthru_idr , & ! nir dir SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
716 : fswthru_idf ! nir dif SW through ice to ocean (W m-2)
717 :
718 : real (kind=dbl_kind), dimension (:), intent(out) :: &
719 : Iswabs , & ! SW absorbed in particular layer (W m-2) ! LCOV_EXCL_LINE
720 : fswpenl ! visible SW entering ice layers (W m-2)
721 :
722 : ! local variables
723 :
724 : real (kind=dbl_kind), parameter :: &
725 : i0vis = 0.70_dbl_kind ! fraction of penetrating solar rad (visible)
726 :
727 : integer (kind=int_kind) :: &
728 : k ! ice layer index
729 :
730 : real (kind=dbl_kind) :: &
731 : fswpen , & ! SW penetrating beneath surface (W m-2) ! LCOV_EXCL_LINE
732 : trantop , & ! transmitted frac of penetrating SW at layer top ! LCOV_EXCL_LINE
733 0 : tranbot ! transmitted frac of penetrating SW at layer bot
734 :
735 : real (kind=dbl_kind) :: &
736 : swabs , & ! net SW down at surface (W m-2) ! LCOV_EXCL_LINE
737 : swabsv , & ! swabs in vis (wvlngth < 700nm) (W/m^2) ! LCOV_EXCL_LINE
738 : swabsi , & ! swabs in nir (wvlngth > 700nm) (W/m^2) ! LCOV_EXCL_LINE
739 : fswpenvdr , & ! penetrating SW, vis direct ! LCOV_EXCL_LINE
740 : fswpenvdf , & ! penetrating SW, vis diffuse ! LCOV_EXCL_LINE
741 : hi , & ! ice thickness (m) ! LCOV_EXCL_LINE
742 : hs , & ! snow thickness (m) ! LCOV_EXCL_LINE
743 : hilyr , & ! ice layer thickness ! LCOV_EXCL_LINE
744 0 : asnow ! fractional area of snow cover
745 :
746 : character(len=*),parameter :: subname='(absorbed_solar)'
747 :
748 : !-----------------------------------------------------------------
749 : ! Initialize
750 : !-----------------------------------------------------------------
751 :
752 0 : trantop = c0
753 0 : tranbot = c0
754 :
755 0 : hs = vsnon / aicen
756 :
757 : !-----------------------------------------------------------------
758 : ! Fractional snow cover
759 : !-----------------------------------------------------------------
760 0 : if (hs > puny) then
761 0 : asnow = hs / (hs + snowpatch)
762 : else
763 0 : asnow = c0
764 : endif
765 :
766 : !-----------------------------------------------------------------
767 : ! Shortwave flux absorbed at surface, absorbed internally,
768 : ! and penetrating to mixed layer.
769 : ! This parameterization assumes that all IR is absorbed at the
770 : ! surface; only visible is absorbed in the ice interior or
771 : ! transmitted to the ocean.
772 : !-----------------------------------------------------------------
773 :
774 : swabsv = swvdr * ( (c1-alvdrni)*(c1-asnow) &
775 : + (c1-alvdrns)*asnow ) & ! LCOV_EXCL_LINE
776 : + swvdf * ( (c1-alvdfni)*(c1-asnow) & ! LCOV_EXCL_LINE
777 0 : + (c1-alvdfns)*asnow )
778 :
779 : swabsi = swidr * ( (c1-alidrni)*(c1-asnow) &
780 : + (c1-alidrns)*asnow ) & ! LCOV_EXCL_LINE
781 : + swidf * ( (c1-alidfni)*(c1-asnow) & ! LCOV_EXCL_LINE
782 0 : + (c1-alidfns)*asnow )
783 :
784 0 : swabs = swabsv + swabsi
785 :
786 0 : fswpenvdr = swvdr * (c1-alvdrni) * (c1-asnow) * i0vis
787 0 : fswpenvdf = swvdf * (c1-alvdfni) * (c1-asnow) * i0vis
788 :
789 : ! no penetrating radiation in near IR
790 : ! fswpenidr = swidr * (c1-alidrni) * (c1-asnow) * i0nir
791 : ! fswpenidf = swidf * (c1-alidfni) * (c1-asnow) * i0nir
792 :
793 0 : fswpen = fswpenvdr + fswpenvdf
794 :
795 0 : fswsfc = swabs - fswpen
796 :
797 0 : trantop = c1 ! transmittance at top of ice
798 :
799 : !-----------------------------------------------------------------
800 : ! penetrating SW absorbed in each ice layer
801 : !-----------------------------------------------------------------
802 :
803 0 : do k = 1, nilyr
804 :
805 0 : hi = vicen / aicen
806 0 : hilyr = hi / real(nilyr,kind=dbl_kind)
807 :
808 0 : tranbot = exp (-kappav * hilyr * real(k,kind=dbl_kind))
809 0 : Iswabs(k) = fswpen * (trantop-tranbot)
810 :
811 : ! bottom of layer k = top of layer k+1
812 0 : trantop = tranbot
813 :
814 : ! bgc layer model
815 0 : if (k == 1) then ! surface flux
816 0 : fswpenl(k) = fswpen
817 0 : fswpenl(k+1) = fswpen * tranbot
818 : else
819 0 : fswpenl(k+1) = fswpen * tranbot
820 : endif
821 : enddo ! nilyr
822 :
823 : ! SW penetrating thru ice into ocean
824 0 : fswthru = fswpen * tranbot
825 0 : fswthru_vdr = fswpenvdr * tranbot
826 0 : fswthru_vdf = fswpenvdf * tranbot
827 0 : fswthru_idr = c0
828 0 : fswthru_idf = c0
829 :
830 : ! SW absorbed in ice interior
831 0 : fswint = fswpen - fswthru
832 :
833 0 : end subroutine absorbed_solar
834 :
835 : ! End ccsm3 shortwave method
836 : !=======================================================================
837 : ! Begin Delta-Eddington shortwave method
838 :
839 : ! Compute initial data for Delta-Eddington method, specifically,
840 : ! the approximate exponential look-up table.
841 : !
842 : ! author: Bruce P. Briegleb, NCAR
843 : ! 2011 ECH modified for melt pond tracers
844 : ! 2013 ECH merged with NCAR version
845 :
846 10791574 : subroutine run_dEdd(dt, &
847 : aicen, vicen, & ! LCOV_EXCL_LINE
848 : vsnon, Tsfcn, & ! LCOV_EXCL_LINE
849 : alvln, apndn, & ! LCOV_EXCL_LINE
850 : hpndn, ipndn, & ! LCOV_EXCL_LINE
851 : aeron, & ! LCOV_EXCL_LINE
852 : trcrn_bgcsw, & ! LCOV_EXCL_LINE
853 : TLAT, TLON, & ! LCOV_EXCL_LINE
854 : calendar_type, & ! LCOV_EXCL_LINE
855 : days_per_year, & ! LCOV_EXCL_LINE
856 : nextsw_cday, yday, & ! LCOV_EXCL_LINE
857 : sec, & ! LCOV_EXCL_LINE
858 : swvdr, swvdf, & ! LCOV_EXCL_LINE
859 : swidr, swidf, & ! LCOV_EXCL_LINE
860 : coszen, fsnow, & ! LCOV_EXCL_LINE
861 : alvdrn, alvdfn, & ! LCOV_EXCL_LINE
862 : alidrn, alidfn, & ! LCOV_EXCL_LINE
863 : fswsfcn, fswintn, & ! LCOV_EXCL_LINE
864 : fswthrun, & ! LCOV_EXCL_LINE
865 : fswthrun_vdr, & ! LCOV_EXCL_LINE
866 : fswthrun_vdf, & ! LCOV_EXCL_LINE
867 : fswthrun_idr, & ! LCOV_EXCL_LINE
868 : fswthrun_idf, & ! LCOV_EXCL_LINE
869 : fswpenln, & ! LCOV_EXCL_LINE
870 : Sswabsn, Iswabsn, & ! LCOV_EXCL_LINE
871 : albicen, albsnon, & ! LCOV_EXCL_LINE
872 : albpndn, apeffn, & ! LCOV_EXCL_LINE
873 : snowfracn, & ! LCOV_EXCL_LINE
874 : dhsn, ffracn, & ! LCOV_EXCL_LINE
875 : rsnow, & ! LCOV_EXCL_LINE
876 : l_print_point, & ! LCOV_EXCL_LINE
877 : initonly)
878 :
879 : integer (kind=int_kind), intent(in) :: &
880 : sec ! elapsed seconds into date
881 :
882 : real (kind=dbl_kind), intent(in), optional :: &
883 : yday ! day of the year
884 :
885 : character (len=char_len), intent(in), optional :: &
886 : calendar_type ! differentiates Gregorian from other calendars
887 :
888 : integer (kind=int_kind), intent(in), optional :: &
889 : days_per_year ! number of days in one year
890 :
891 : real (kind=dbl_kind), intent(in), optional :: &
892 : nextsw_cday ! julian day of next shortwave calculation
893 :
894 : real(kind=dbl_kind), intent(in) :: &
895 : dt, & ! time step (s) ! LCOV_EXCL_LINE
896 : TLAT, & ! latitude of temp pts (radians) ! LCOV_EXCL_LINE
897 : TLON, & ! longitude of temp pts (radians) ! LCOV_EXCL_LINE
898 : swvdr, & ! sw down, visible, direct (W/m^2) ! LCOV_EXCL_LINE
899 : swvdf, & ! sw down, visible, diffuse (W/m^2) ! LCOV_EXCL_LINE
900 : swidr, & ! sw down, near IR, direct (W/m^2) ! LCOV_EXCL_LINE
901 : swidf, & ! sw down, near IR, diffuse (W/m^2) ! LCOV_EXCL_LINE
902 : fsnow ! snowfall rate (kg/m^2 s)
903 :
904 : real(kind=dbl_kind), dimension(:), intent(in) :: &
905 : aicen, & ! concentration of ice ! LCOV_EXCL_LINE
906 : vicen, & ! volume per unit area of ice (m) ! LCOV_EXCL_LINE
907 : vsnon, & ! volume per unit area of snow (m) ! LCOV_EXCL_LINE
908 : Tsfcn, & ! surface temperature (deg C) ! LCOV_EXCL_LINE
909 : alvln, & ! level-ice area fraction ! LCOV_EXCL_LINE
910 : apndn, & ! pond area fraction ! LCOV_EXCL_LINE
911 : hpndn, & ! pond depth (m) ! LCOV_EXCL_LINE
912 : ipndn ! pond refrozen lid thickness (m)
913 :
914 : real(kind=dbl_kind), dimension(:,:), intent(in) :: &
915 : aeron, & ! aerosols (kg/m^3) ! LCOV_EXCL_LINE
916 : trcrn_bgcsw ! zaerosols (kg/m^3) + chlorophyll on shorthwave grid
917 :
918 : real(kind=dbl_kind), dimension(:), intent(inout) :: &
919 : ffracn, & ! fraction of fsurfn used to melt ipond ! LCOV_EXCL_LINE
920 : dhsn ! depth difference for snow on sea ice and pond ice
921 :
922 : real(kind=dbl_kind), intent(inout) :: &
923 : coszen ! cosine solar zenith angle, < 0 for sun below horizon
924 :
925 : real(kind=dbl_kind), dimension(:), intent(inout) :: &
926 : alvdrn, & ! visible direct albedo (fraction) ! LCOV_EXCL_LINE
927 : alvdfn, & ! near-ir direct albedo (fraction) ! LCOV_EXCL_LINE
928 : alidrn, & ! visible diffuse albedo (fraction) ! LCOV_EXCL_LINE
929 : alidfn, & ! near-ir diffuse albedo (fraction) ! LCOV_EXCL_LINE
930 : fswsfcn, & ! SW absorbed at ice/snow surface (W m-2) ! LCOV_EXCL_LINE
931 : fswintn, & ! SW absorbed in ice interior, below surface (W m-2) ! LCOV_EXCL_LINE
932 : fswthrun, & ! SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
933 : albicen, & ! albedo bare ice ! LCOV_EXCL_LINE
934 : albsnon, & ! albedo snow ! LCOV_EXCL_LINE
935 : albpndn, & ! albedo pond ! LCOV_EXCL_LINE
936 : apeffn, & ! effective pond area used for radiation calculation ! LCOV_EXCL_LINE
937 : snowfracn ! snow fraction on each category used for radiation
938 :
939 : real(kind=dbl_kind), dimension(:), intent(out), optional :: &
940 : fswthrun_vdr, & ! vis dir SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
941 : fswthrun_vdf, & ! vis dif SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
942 : fswthrun_idr, & ! nir dir SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
943 : fswthrun_idf ! nir dif SW through ice to ocean (W/m^2)
944 :
945 : real(kind=dbl_kind), dimension(:,:), intent(inout) :: &
946 : Sswabsn , & ! SW radiation absorbed in snow layers (W m-2) ! LCOV_EXCL_LINE
947 : Iswabsn , & ! SW radiation absorbed in ice layers (W m-2) ! LCOV_EXCL_LINE
948 : fswpenln ! visible SW entering ice layers (W m-2)
949 :
950 : real(kind=dbl_kind), dimension(:,:), intent(inout), optional :: &
951 : rsnow ! snow grain radius tracer (10^-6 m)
952 :
953 : logical (kind=log_kind), intent(in) :: &
954 : l_print_point ! print diagnostic information
955 :
956 : logical (kind=log_kind), optional :: &
957 : initonly ! flag to indicate init only, default is false
958 :
959 : ! local variables
960 : ! snow variables for Delta-Eddington shortwave
961 : real (kind=dbl_kind) :: &
962 : fsn , & ! snow horizontal fraction ! LCOV_EXCL_LINE
963 : hsn , & ! snow depth (m) ! LCOV_EXCL_LINE
964 : hsnlvl , & ! snow depth over level ice (m) ! LCOV_EXCL_LINE
965 : vsn , & ! snow volume ! LCOV_EXCL_LINE
966 2898172 : alvl ! area fraction of level ice
967 :
968 : real (kind=dbl_kind), dimension (nslyr) :: &
969 : rhosnwn , & ! snow density (kg/m3) ! LCOV_EXCL_LINE
970 21583148 : rsnwn ! snow grain radius (micrometers)
971 :
972 : ! pond variables for Delta-Eddington shortwave
973 : real (kind=dbl_kind) :: &
974 : fpn , & ! pond fraction of ice cover ! LCOV_EXCL_LINE
975 2898172 : hpn ! actual pond depth (m)
976 :
977 : integer (kind=int_kind) :: &
978 : n , & ! thickness category index ! LCOV_EXCL_LINE
979 : k ! snow layer index
980 :
981 : real (kind=dbl_kind) :: &
982 : ipn , & ! refrozen pond ice thickness (m), mean over ice fraction ! LCOV_EXCL_LINE
983 : hp , & ! pond depth ! LCOV_EXCL_LINE
984 : hs , & ! snow depth ! LCOV_EXCL_LINE
985 : asnow , & ! fractional area of snow cover ! LCOV_EXCL_LINE
986 : rp , & ! volume fraction of retained melt water to total liquid content ! LCOV_EXCL_LINE
987 : hmx , & ! maximum available snow infiltration equivalent depth ! LCOV_EXCL_LINE
988 : dhs , & ! local difference in snow depth on sea ice and pond ice ! LCOV_EXCL_LINE
989 : spn , & ! snow depth on refrozen pond (m) ! LCOV_EXCL_LINE
990 2898172 : tmp ! 0 or 1
991 :
992 : ! needed for optional fswthrun arrays when passed as scalars
993 : real (kind=dbl_kind) :: &
994 : l_fswthru_vdr , & ! vis dir SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
995 : l_fswthru_vdf , & ! vis dif SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
996 : l_fswthru_idr , & ! nir dir SW through ice to ocean (W m-2) ! LCOV_EXCL_LINE
997 2898172 : l_fswthru_idf ! nir dif SW through ice to ocean (W m-2)
998 :
999 : logical (kind=log_kind) :: &
1000 : l_initonly ! local initonly value
1001 :
1002 : real(kind=dbl_kind), dimension(nslyr) :: &
1003 16587918 : l_rsnows ! snow grain radius tracer (10^-6 m)
1004 :
1005 : character(len=*),parameter :: subname='(run_dEdd)'
1006 :
1007 10791574 : l_initonly = .false.
1008 10791574 : if (present(initonly)) then
1009 71830 : l_initonly = initonly
1010 : endif
1011 :
1012 21583148 : l_rsnows(:) = c0
1013 :
1014 : ! cosine of the zenith angle
1015 : #ifdef CESMCOUPLED
1016 : call compute_coszen (TLAT, TLON, yday, sec, coszen, &
1017 : days_per_year, nextsw_cday, calendar_type)
1018 : #else
1019 10791574 : call compute_coszen (TLAT, TLON, yday, sec, coszen)
1020 : #endif
1021 10791574 : if (icepack_warnings_aborted(subname)) return
1022 :
1023 64749444 : do n = 1, ncat
1024 :
1025 : ! note that rhosnwn, rsnw, fp, hp and Sswabs ARE NOT dimensioned with ncat
1026 : ! BPB 19 Dec 2006
1027 :
1028 : ! set snow properties
1029 53957870 : fsn = c0
1030 53957870 : hsn = c0
1031 107915740 : rhosnwn(:) = c0
1032 107915740 : rsnwn(:) = c0
1033 53957870 : apeffn(n) = c0 ! for history
1034 53957870 : snowfracn(n) = c0 ! for history
1035 :
1036 64749444 : if (aicen(n) > puny) then
1037 :
1038 34053937 : if (snwgrain) then
1039 0 : l_rsnows(:) = rsnow(:,n)
1040 : endif
1041 : call shortwave_dEdd_set_snow(R_snw, &
1042 : dT_mlt, rsnw_mlt, & ! LCOV_EXCL_LINE
1043 : aicen(n), vsnon(n), & ! LCOV_EXCL_LINE
1044 : Tsfcn(n), fsn, & ! LCOV_EXCL_LINE
1045 : hs0, hsn, & ! LCOV_EXCL_LINE
1046 : rhosnwn, rsnwn, & ! LCOV_EXCL_LINE
1047 34053937 : l_rsnows(:))
1048 34053937 : if (icepack_warnings_aborted(subname)) return
1049 :
1050 : ! set pond properties
1051 34053937 : if (tr_pond_lvl) then
1052 34053937 : hsnlvl = hsn ! initialize
1053 34053937 : if (trim(snwredist) == 'bulk') then
1054 0 : hsnlvl = hsn / (c1 + snwlvlfac*(c1-alvln(n)))
1055 : ! snow volume over level ice
1056 0 : alvl = aicen(n) * alvln(n)
1057 0 : if (alvl > puny) then
1058 0 : vsn = hsnlvl * alvl
1059 : else
1060 0 : vsn = vsnon(n)
1061 0 : alvl = aicen(n)
1062 : endif
1063 : ! set snow properties over level ice
1064 : call shortwave_dEdd_set_snow(R_snw, &
1065 : dT_mlt, rsnw_mlt, & ! LCOV_EXCL_LINE
1066 : alvl, vsn, & ! LCOV_EXCL_LINE
1067 : Tsfcn(n), fsn, & ! LCOV_EXCL_LINE
1068 : hs0, hsnlvl, & ! LCOV_EXCL_LINE
1069 : rhosnwn(:), rsnwn(:), & ! LCOV_EXCL_LINE
1070 0 : l_rsnows(:))
1071 0 : if (icepack_warnings_aborted(subname)) return
1072 : endif ! snwredist
1073 :
1074 34053937 : fpn = c0 ! fraction of ice covered in pond
1075 34053937 : hpn = c0 ! pond depth over fpn
1076 : ! refrozen pond lid thickness avg over ice
1077 : ! allow snow to cover pond ice
1078 34053937 : ipn = alvln(n) * apndn(n) * ipndn(n)
1079 34053937 : dhs = dhsn(n) ! snow depth difference, sea ice - pond
1080 : if (.not. l_initonly .and. ipn > puny .and. &
1081 : dhs < puny .and. fsnow*dt > hs_min) & ! LCOV_EXCL_LINE
1082 99754 : dhs = hsnlvl - fsnow*dt ! initialize dhs>0
1083 34053937 : spn = hsnlvl - dhs ! snow depth on pond ice
1084 34053937 : if (.not. l_initonly .and. ipn*spn < puny) dhs = c0
1085 34053937 : dhsn(n) = dhs ! save: constant until reset to 0
1086 :
1087 : ! not using ipn assumes that lid ice is perfectly clear
1088 : ! if (ipn <= 0.3_dbl_kind) then
1089 :
1090 : ! fraction of ice area
1091 34053937 : fpn = apndn(n) * alvln(n)
1092 : ! pond depth over fraction fpn
1093 34053937 : hpn = hpndn(n)
1094 :
1095 : ! reduce effective pond area absorbing surface heat flux
1096 : ! due to flux already having been used to melt pond ice
1097 34053937 : fpn = (c1 - ffracn(n)) * fpn
1098 :
1099 : ! taper pond area with snow on pond ice
1100 34053937 : if (dhs > puny .and. spn >= puny .and. hs1 > puny) then
1101 471734 : asnow = min(spn/hs1, c1)
1102 471734 : fpn = (c1 - asnow) * fpn
1103 : endif
1104 :
1105 : ! infiltrate snow
1106 34053937 : hp = hpn
1107 34053937 : if (hp > puny) then
1108 20828473 : hs = hsnlvl
1109 20828473 : rp = rhofresh*hp/(rhofresh*hp + rhos*hs)
1110 20828473 : if (rp < p15) then
1111 12809317 : fpn = c0
1112 12809317 : hpn = c0
1113 : else
1114 8019156 : hmx = hs*(rhofresh - rhos)/rhofresh
1115 8019156 : tmp = max(c0, sign(c1, hp-hmx)) ! 1 if hp>=hmx, else 0
1116 : hp = (rhofresh*hp + rhos*hs*tmp) &
1117 8019156 : / (rhofresh - rhos*(c1-tmp))
1118 8019156 : hsn = hsn - hp*fpn*(c1-tmp)
1119 8019156 : hpn = hp * tmp
1120 8019156 : fpn = fpn * tmp
1121 : endif
1122 : endif ! hp > puny
1123 :
1124 : ! Zero out fraction of thin ponds for radiation only
1125 34053937 : if (hpn < hpmin) fpn = c0
1126 34053937 : fsn = min(fsn, c1-fpn)
1127 :
1128 : ! endif ! masking by lid ice
1129 34053937 : apeffn(n) = fpn ! for history
1130 :
1131 0 : elseif (tr_pond_topo) then
1132 : ! Lid effective if thicker than hp1
1133 0 : if (apndn(n)*aicen(n) > puny .and. ipndn(n) < hp1) then
1134 0 : fpn = apndn(n)
1135 : else
1136 0 : fpn = c0
1137 : endif
1138 0 : if (apndn(n) > puny) then
1139 0 : hpn = hpndn(n)
1140 : else
1141 0 : fpn = c0
1142 0 : hpn = c0
1143 : endif
1144 :
1145 : ! Zero out fraction of thin ponds for radiation only
1146 0 : if (hpn < hpmin) fpn = c0
1147 :
1148 : ! If ponds are present snow fraction reduced to
1149 : ! non-ponded part dEdd scheme
1150 0 : fsn = min(fsn, c1-fpn)
1151 :
1152 0 : apeffn(n) = fpn
1153 : else
1154 0 : fpn = c0
1155 0 : hpn = c0
1156 0 : call shortwave_dEdd_set_pond(Tsfcn(n), &
1157 : fsn, fpn, & ! LCOV_EXCL_LINE
1158 0 : hpn)
1159 0 : if (icepack_warnings_aborted(subname)) return
1160 :
1161 0 : apeffn(n) = fpn ! for history
1162 0 : fpn = c0
1163 0 : hpn = c0
1164 : endif ! pond type
1165 :
1166 34053937 : snowfracn(n) = fsn ! for history
1167 :
1168 : call shortwave_dEdd( &
1169 : coszen, & ! LCOV_EXCL_LINE
1170 : aicen(n), vicen(n), & ! LCOV_EXCL_LINE
1171 : hsn, fsn, & ! LCOV_EXCL_LINE
1172 : rhosnwn, rsnwn, & ! LCOV_EXCL_LINE
1173 : fpn, hpn, & ! LCOV_EXCL_LINE
1174 : aeron(:,n), & ! LCOV_EXCL_LINE
1175 : swvdr, swvdf, & ! LCOV_EXCL_LINE
1176 : swidr, swidf, & ! LCOV_EXCL_LINE
1177 : alvdrn(n), alvdfn(n), & ! LCOV_EXCL_LINE
1178 : alidrn(n), alidfn(n), & ! LCOV_EXCL_LINE
1179 : fswsfcn(n), fswintn(n), & ! LCOV_EXCL_LINE
1180 : fswthru=fswthrun(n), & ! LCOV_EXCL_LINE
1181 : fswthru_vdr=l_fswthru_vdr, & ! LCOV_EXCL_LINE
1182 : fswthru_vdf=l_fswthru_vdf, & ! LCOV_EXCL_LINE
1183 : fswthru_idr=l_fswthru_idr, & ! LCOV_EXCL_LINE
1184 : fswthru_idf=l_fswthru_idf, & ! LCOV_EXCL_LINE
1185 : Sswabs=Sswabsn(:,n), & ! LCOV_EXCL_LINE
1186 : Iswabs=Iswabsn(:,n), & ! LCOV_EXCL_LINE
1187 : albice=albicen(n), & ! LCOV_EXCL_LINE
1188 : albsno=albsnon(n), & ! LCOV_EXCL_LINE
1189 : albpnd=albpndn(n), & ! LCOV_EXCL_LINE
1190 : fswpenl=fswpenln(:,n), & ! LCOV_EXCL_LINE
1191 : zbio=trcrn_bgcsw(:,n), & ! LCOV_EXCL_LINE
1192 40260637 : l_print_point=l_print_point)
1193 :
1194 34053937 : if (icepack_warnings_aborted(subname)) return
1195 :
1196 34053937 : if(present(fswthrun_vdr)) fswthrun_vdr(n) = l_fswthru_vdr
1197 34053937 : if(present(fswthrun_vdf)) fswthrun_vdf(n) = l_fswthru_vdf
1198 34053937 : if(present(fswthrun_idr)) fswthrun_idr(n) = l_fswthru_idr
1199 34053937 : if(present(fswthrun_idf)) fswthrun_idf(n) = l_fswthru_idf
1200 :
1201 34053937 : if (present(rsnow) .and. .not. snwgrain) then
1202 68107874 : do k = 1,nslyr
1203 68107874 : rsnow(k,n) = rsnwn(k) ! for history
1204 : enddo
1205 : endif
1206 :
1207 : endif ! aicen > puny
1208 :
1209 : enddo ! ncat
1210 :
1211 : end subroutine run_dEdd
1212 :
1213 : !=======================================================================
1214 : !
1215 : ! Compute snow/bare ice/ponded ice shortwave albedos, absorbed and transmitted
1216 : ! flux using the Delta-Eddington solar radiation method as described in:
1217 : !
1218 : ! A Delta-Eddington Multiple Scattering Parameterization for Solar Radiation
1219 : ! in the Sea Ice Component of the Community Climate System Model
1220 : ! B.P.Briegleb and B.Light NCAR/TN-472+STR February 2007
1221 : !
1222 : ! Compute shortwave albedos and fluxes for three surface types:
1223 : ! snow over ice, bare ice and ponded ice.
1224 : !
1225 : ! Albedos and fluxes are output for later use by thermodynamic routines.
1226 : ! Invokes three calls to compute_dEdd, which sets inherent optical properties
1227 : ! appropriate for the surface type. Within compute_dEdd, a call to solution_dEdd
1228 : ! evaluates the Delta-Eddington solution. The final albedos and fluxes are then
1229 : ! evaluated in compute_dEdd. Albedos and fluxes are transferred to output in
1230 : ! this routine.
1231 : !
1232 : ! NOTE regarding albedo diagnostics: This method yields zero albedo values
1233 : ! if there is no incoming solar and thus the albedo diagnostics are masked
1234 : ! out when the sun is below the horizon. To estimate albedo from the history
1235 : ! output (post-processing), compute ice albedo using
1236 : ! (1 - albedo)*swdn = swabs. -ECH
1237 : !
1238 : ! author: Bruce P. Briegleb, NCAR
1239 : ! 2013: E Hunke merged with NCAR version
1240 : !
1241 34053937 : subroutine shortwave_dEdd (coszen, &
1242 : aice, vice, & ! LCOV_EXCL_LINE
1243 : hs, fs, & ! LCOV_EXCL_LINE
1244 : rhosnw, rsnw, & ! LCOV_EXCL_LINE
1245 : fp, hp, & ! LCOV_EXCL_LINE
1246 : aero, & ! LCOV_EXCL_LINE
1247 : swvdr, swvdf, & ! LCOV_EXCL_LINE
1248 : swidr, swidf, & ! LCOV_EXCL_LINE
1249 : alvdr, alvdf, & ! LCOV_EXCL_LINE
1250 : alidr, alidf, & ! LCOV_EXCL_LINE
1251 : fswsfc, fswint, & ! LCOV_EXCL_LINE
1252 : fswthru, & ! LCOV_EXCL_LINE
1253 : fswthru_vdr, & ! LCOV_EXCL_LINE
1254 : fswthru_vdf, & ! LCOV_EXCL_LINE
1255 : fswthru_idr, & ! LCOV_EXCL_LINE
1256 : fswthru_idf, & ! LCOV_EXCL_LINE
1257 : Sswabs, & ! LCOV_EXCL_LINE
1258 : Iswabs, albice, & ! LCOV_EXCL_LINE
1259 : albsno, albpnd, & ! LCOV_EXCL_LINE
1260 : fswpenl, zbio, & ! LCOV_EXCL_LINE
1261 : l_print_point )
1262 :
1263 : real (kind=dbl_kind), intent(in) :: &
1264 : aice , & ! concentration of ice ! LCOV_EXCL_LINE
1265 : vice , & ! volume of ice ! LCOV_EXCL_LINE
1266 : hs , & ! snow depth ! LCOV_EXCL_LINE
1267 : fs ! horizontal coverage of snow
1268 :
1269 : real (kind=dbl_kind), dimension (:), intent(in) :: &
1270 : rhosnw , & ! density in snow layer (kg/m3) ! LCOV_EXCL_LINE
1271 : rsnw , & ! grain radius in snow layer (m) ! LCOV_EXCL_LINE
1272 : aero , & ! aerosol tracers ! LCOV_EXCL_LINE
1273 : zbio ! shortwave tracers (zaero+chla)
1274 :
1275 : real (kind=dbl_kind), intent(in) :: &
1276 : fp , & ! pond fractional coverage (0 to 1) ! LCOV_EXCL_LINE
1277 : hp , & ! pond depth (m) ! LCOV_EXCL_LINE
1278 : swvdr , & ! sw down, visible, direct (W/m^2) ! LCOV_EXCL_LINE
1279 : swvdf , & ! sw down, visible, diffuse (W/m^2) ! LCOV_EXCL_LINE
1280 : swidr , & ! sw down, near IR, direct (W/m^2) ! LCOV_EXCL_LINE
1281 : swidf ! sw down, near IR, diffuse (W/m^2)
1282 :
1283 : real (kind=dbl_kind), intent(inout) :: &
1284 : coszen , & ! cosine of solar zenith angle ! LCOV_EXCL_LINE
1285 : alvdr , & ! visible, direct, albedo (fraction) ! LCOV_EXCL_LINE
1286 : alvdf , & ! visible, diffuse, albedo (fraction) ! LCOV_EXCL_LINE
1287 : alidr , & ! near-ir, direct, albedo (fraction) ! LCOV_EXCL_LINE
1288 : alidf , & ! near-ir, diffuse, albedo (fraction) ! LCOV_EXCL_LINE
1289 : fswsfc , & ! SW absorbed at snow/bare ice/pondedi ice surface (W m-2) ! LCOV_EXCL_LINE
1290 : fswint , & ! SW interior absorption (below surface, above ocean,W m-2) ! LCOV_EXCL_LINE
1291 : fswthru ! SW through snow/bare ice/ponded ice into ocean (W m-2)
1292 :
1293 : real (kind=dbl_kind), intent(out) :: &
1294 : fswthru_vdr , & ! vis dir SW through snow/bare ice/ponded ice into ocean (W m-2) ! LCOV_EXCL_LINE
1295 : fswthru_vdf , & ! vis dif SW through snow/bare ice/ponded ice into ocean (W m-2) ! LCOV_EXCL_LINE
1296 : fswthru_idr , & ! nir dir SW through snow/bare ice/ponded ice into ocean (W m-2) ! LCOV_EXCL_LINE
1297 : fswthru_idf ! nir dif SW through snow/bare ice/ponded ice into ocean (W m-2)
1298 :
1299 : real (kind=dbl_kind), dimension (:), intent(inout) :: &
1300 : fswpenl , & ! visible SW entering ice layers (W m-2) ! LCOV_EXCL_LINE
1301 : Sswabs , & ! SW absorbed in snow layer (W m-2) ! LCOV_EXCL_LINE
1302 : Iswabs ! SW absorbed in ice layer (W m-2)
1303 :
1304 : real (kind=dbl_kind), intent(out) :: &
1305 : albice , & ! bare ice albedo, for history ! LCOV_EXCL_LINE
1306 : albsno , & ! snow albedo, for history ! LCOV_EXCL_LINE
1307 : albpnd ! pond albedo, for history
1308 :
1309 : logical (kind=log_kind) , intent(in) :: &
1310 : l_print_point
1311 :
1312 : ! local variables
1313 :
1314 : real (kind=dbl_kind) :: &
1315 : netsw , & ! net shortwave ! LCOV_EXCL_LINE
1316 : fnidr , & ! fraction of direct to total down surface flux in nir ! LCOV_EXCL_LINE
1317 : hstmp , & ! snow thickness (set to 0 for bare ice case) ! LCOV_EXCL_LINE
1318 : hi , & ! ice thickness (all sea ice layers, m) ! LCOV_EXCL_LINE
1319 3103350 : fi ! snow/bare ice fractional coverage (0 to 1)
1320 :
1321 : real (kind=dbl_kind), dimension (4*n_aero) :: &
1322 49570687 : aero_mp ! aerosol mass path in kg/m2
1323 :
1324 : integer (kind=int_kind) :: &
1325 : srftyp ! surface type over ice: (0=air, 1=snow, 2=pond)
1326 :
1327 : integer (kind=int_kind) :: &
1328 : k , & ! level index ! LCOV_EXCL_LINE
1329 : na , & ! aerosol index ! LCOV_EXCL_LINE
1330 : klev , & ! number of radiation layers - 1 ! LCOV_EXCL_LINE
1331 : klevp ! number of radiation interfaces - 1
1332 : ! (0 layer is included also)
1333 :
1334 : real (kind=dbl_kind) :: &
1335 3103350 : vsno ! volume of snow
1336 :
1337 : real (kind=dbl_kind) :: &
1338 : swdn , & ! swvdr(i,j)+swvdf(i,j)+swidr(i,j)+swidf(i,j) ! LCOV_EXCL_LINE
1339 : swab , & ! fswsfc(i,j)+fswint(i,j)+fswthru(i,j) ! LCOV_EXCL_LINE
1340 3103350 : swalb ! (1.-swab/(swdn+.0001))
1341 :
1342 : ! for history
1343 : real (kind=dbl_kind) :: &
1344 : avdrl , & ! visible, direct, albedo (fraction) ! LCOV_EXCL_LINE
1345 : avdfl , & ! visible, diffuse, albedo (fraction) ! LCOV_EXCL_LINE
1346 : aidrl , & ! near-ir, direct, albedo (fraction) ! LCOV_EXCL_LINE
1347 3103350 : aidfl ! near-ir, diffuse, albedo (fraction)
1348 :
1349 : character(len=*),parameter :: subname='(shortwave_dEdd)'
1350 :
1351 : !-----------------------------------------------------------------------
1352 :
1353 34053937 : klev = nslyr + nilyr + 1 ! number of radiation layers - 1
1354 34053937 : klevp = klev + 1 ! number of radiation interfaces - 1
1355 : ! (0 layer is included also)
1356 :
1357 : ! set storage albedos and fluxes to zero for accumulation over surface types
1358 34053937 : hstmp = c0
1359 34053937 : hi = c0
1360 34053937 : fi = c0
1361 34053937 : alvdr = c0
1362 34053937 : alvdf = c0
1363 34053937 : alidr = c0
1364 34053937 : alidf = c0
1365 34053937 : avdrl = c0
1366 34053937 : avdfl = c0
1367 34053937 : aidrl = c0
1368 34053937 : aidfl = c0
1369 34053937 : fswsfc = c0
1370 34053937 : fswint = c0
1371 34053937 : fswthru = c0
1372 34053937 : fswthru_vdr = c0
1373 34053937 : fswthru_vdf = c0
1374 34053937 : fswthru_idr = c0
1375 34053937 : fswthru_idf = c0
1376 : ! compute fraction of nir down direct to total over all points:
1377 34053937 : fnidr = c0
1378 34053937 : if( swidr + swidf > puny ) then
1379 2730303 : fnidr = swidr/(swidr+swidf)
1380 : endif
1381 34053937 : albice = c0
1382 34053937 : albsno = c0
1383 34053937 : albpnd = c0
1384 306485433 : fswpenl(:) = c0
1385 68107874 : Sswabs (:) = c0
1386 272431496 : Iswabs (:) = c0
1387 :
1388 : ! compute aerosol mass path
1389 :
1390 170269685 : aero_mp(:) = c0
1391 34053937 : if( tr_aero ) then
1392 : ! check 4 layers for each aerosol, a snow SSL, snow below SSL,
1393 : ! sea ice SSL, and sea ice below SSL, in that order.
1394 0 : if (size(aero) < 4*n_aero) then
1395 0 : call icepack_warnings_add(subname//' ERROR: size(aero) too small')
1396 0 : call icepack_warnings_setabort(.true.,__FILE__,__LINE__)
1397 0 : return
1398 : endif
1399 0 : do na = 1, 4*n_aero, 4
1400 0 : vsno = hs * aice
1401 0 : netsw = swvdr + swidr + swvdf + swidf
1402 0 : if (netsw > puny) then ! sun above horizon
1403 0 : aero_mp(na ) = aero(na )*vsno
1404 0 : aero_mp(na+1) = aero(na+1)*vsno
1405 0 : aero_mp(na+2) = aero(na+2)*vice
1406 0 : aero_mp(na+3) = aero(na+3)*vice
1407 : endif ! aice > 0 and netsw > 0
1408 : enddo ! na
1409 : endif ! if aerosols
1410 :
1411 : ! compute shortwave radiation accounting for snow/ice (both snow over
1412 : ! ice and bare ice) and ponded ice (if any):
1413 :
1414 : ! sea ice points with sun above horizon
1415 34053937 : netsw = swvdr + swidr + swvdf + swidf
1416 34053937 : if (netsw > puny) then ! sun above horizon
1417 2730303 : coszen = max(puny,coszen)
1418 : ! evaluate sea ice thickness and fraction
1419 2730303 : hi = vice / aice
1420 2730303 : fi = c1 - fs - fp
1421 : ! bare sea ice points
1422 2730303 : if(fi > c0) then
1423 : ! calculate bare sea ice
1424 :
1425 322330 : srftyp = 0
1426 : call compute_dEdd_3bd( &
1427 : klev, klevp, zbio, fnidr, coszen, & ! LCOV_EXCL_LINE
1428 : swvdr, swvdf, swidr, swidf, srftyp, & ! LCOV_EXCL_LINE
1429 : hstmp, rhosnw, rsnw, hi, hp, & ! LCOV_EXCL_LINE
1430 : fi, aero_mp, avdrl, avdfl, & ! LCOV_EXCL_LINE
1431 : aidrl, aidfl, fswsfc, fswint, fswthru, & ! LCOV_EXCL_LINE
1432 : fswthru_vdr, fswthru_vdf, & ! LCOV_EXCL_LINE
1433 : fswthru_idr, fswthru_idf, & ! LCOV_EXCL_LINE
1434 322330 : Sswabs, Iswabs, fswpenl )
1435 322330 : if (icepack_warnings_aborted(subname)) return
1436 :
1437 322330 : alvdr = alvdr + avdrl*fi
1438 322330 : alvdf = alvdf + avdfl*fi
1439 322330 : alidr = alidr + aidrl*fi
1440 322330 : alidf = alidf + aidfl*fi
1441 : ! for history
1442 : albice = albice &
1443 : + awtvdr*avdrl + awtidr*aidrl & ! LCOV_EXCL_LINE
1444 322330 : + awtvdf*avdfl + awtidf*aidfl
1445 : endif
1446 : endif
1447 :
1448 : ! sea ice points with sun above horizon
1449 34053937 : netsw = swvdr + swidr + swvdf + swidf
1450 34053937 : if (netsw > puny) then ! sun above horizon
1451 2730303 : coszen = max(puny,coszen)
1452 : ! snow-covered sea ice points
1453 2730303 : if(fs > c0) then
1454 : ! calculate snow covered sea ice
1455 :
1456 2448232 : srftyp = 1
1457 2448232 : if (trim(shortwave) == 'dEdd_snicar_ad') then
1458 : call compute_dEdd_5bd( &
1459 : klev, klevp, zbio, fnidr, coszen, & ! LCOV_EXCL_LINE
1460 : swvdr, swvdf, swidr, swidf, srftyp, & ! LCOV_EXCL_LINE
1461 : hs, rhosnw, rsnw, hi, hp, & ! LCOV_EXCL_LINE
1462 : fs, aero_mp, avdrl, avdfl, & ! LCOV_EXCL_LINE
1463 : aidrl, aidfl, fswsfc, fswint, fswthru, & ! LCOV_EXCL_LINE
1464 : fswthru_vdr, fswthru_vdf, & ! LCOV_EXCL_LINE
1465 : fswthru_idr, fswthru_idf, & ! LCOV_EXCL_LINE
1466 0 : Sswabs, Iswabs, fswpenl )
1467 :
1468 : else
1469 : !echmod - this can be combined with the 5bd call above, if we use module data
1470 : call compute_dEdd_3bd( &
1471 : klev, klevp, zbio, fnidr, coszen, & ! LCOV_EXCL_LINE
1472 : swvdr, swvdf, swidr, swidf, srftyp, & ! LCOV_EXCL_LINE
1473 : hs, rhosnw, rsnw, hi, hp, & ! LCOV_EXCL_LINE
1474 : fs, aero_mp, avdrl, avdfl, & ! LCOV_EXCL_LINE
1475 : aidrl, aidfl, fswsfc, fswint, fswthru, & ! LCOV_EXCL_LINE
1476 : fswthru_vdr, fswthru_vdf, & ! LCOV_EXCL_LINE
1477 : fswthru_idr, fswthru_idf, & ! LCOV_EXCL_LINE
1478 2448232 : Sswabs, Iswabs, fswpenl )
1479 : endif
1480 2448232 : if (icepack_warnings_aborted(subname)) return
1481 :
1482 2448232 : alvdr = alvdr + avdrl*fs
1483 2448232 : alvdf = alvdf + avdfl*fs
1484 2448232 : alidr = alidr + aidrl*fs
1485 2448232 : alidf = alidf + aidfl*fs
1486 : ! for history
1487 : albsno = albsno &
1488 : + awtvdr*avdrl + awtidr*aidrl & ! LCOV_EXCL_LINE
1489 2448232 : + awtvdf*avdfl + awtidf*aidfl
1490 : endif
1491 : endif
1492 :
1493 34053937 : hi = c0
1494 :
1495 : ! sea ice points with sun above horizon
1496 34053937 : netsw = swvdr + swidr + swvdf + swidf
1497 34053937 : if (netsw > puny) then ! sun above horizon
1498 2730303 : coszen = max(puny,coszen)
1499 2730303 : hi = vice / aice
1500 : ! if nonzero pond fraction and sufficient pond depth
1501 : ! if( fp > puny .and. hp > hpmin ) then
1502 2730303 : if (fp > puny) then
1503 :
1504 : ! calculate ponded ice
1505 :
1506 347559 : srftyp = 2
1507 : call compute_dEdd_3bd( &
1508 : klev, klevp, zbio, fnidr, coszen, & ! LCOV_EXCL_LINE
1509 : swvdr, swvdf, swidr, swidf, srftyp, & ! LCOV_EXCL_LINE
1510 : hs, rhosnw, rsnw, hi, hp, & ! LCOV_EXCL_LINE
1511 : fp, aero_mp, avdrl, avdfl, & ! LCOV_EXCL_LINE
1512 : aidrl, aidfl, fswsfc, fswint, fswthru, & ! LCOV_EXCL_LINE
1513 : fswthru_vdr, fswthru_vdf, & ! LCOV_EXCL_LINE
1514 : fswthru_idr, fswthru_idf, & ! LCOV_EXCL_LINE
1515 347559 : Sswabs, Iswabs, fswpenl )
1516 347559 : if (icepack_warnings_aborted(subname)) return
1517 :
1518 347559 : alvdr = alvdr + avdrl*fp
1519 347559 : alvdf = alvdf + avdfl*fp
1520 347559 : alidr = alidr + aidrl*fp
1521 347559 : alidf = alidf + aidfl*fp
1522 : ! for history
1523 : albpnd = albpnd &
1524 : + awtvdr*avdrl + awtidr*aidrl & ! LCOV_EXCL_LINE
1525 347559 : + awtvdf*avdfl + awtidf*aidfl
1526 : endif
1527 : endif
1528 :
1529 : ! if no incoming shortwave, set albedos to 1
1530 34053937 : netsw = swvdr + swidr + swvdf + swidf
1531 34053937 : if (netsw <= puny) then ! sun above horizon
1532 31323634 : alvdr = c1
1533 31323634 : alvdf = c1
1534 31323634 : alidr = c1
1535 31323634 : alidf = c1
1536 : endif
1537 :
1538 34053937 : if (l_print_point .and. netsw > puny) then
1539 :
1540 0 : write(warnstr,*) subname, ' printing point'
1541 0 : call icepack_warnings_add(warnstr)
1542 0 : write(warnstr,*) subname, ' coszen = ', &
1543 0 : coszen
1544 0 : call icepack_warnings_add(warnstr)
1545 0 : write(warnstr,*) subname, ' swvdr swvdf = ', &
1546 0 : swvdr,swvdf
1547 0 : call icepack_warnings_add(warnstr)
1548 0 : write(warnstr,*) subname, ' swidr swidf = ', &
1549 0 : swidr,swidf
1550 0 : call icepack_warnings_add(warnstr)
1551 0 : write(warnstr,*) subname, ' aice = ', &
1552 0 : aice
1553 0 : call icepack_warnings_add(warnstr)
1554 0 : write(warnstr,*) subname, ' hs = ', &
1555 0 : hs
1556 0 : call icepack_warnings_add(warnstr)
1557 0 : write(warnstr,*) subname, ' hp = ', &
1558 0 : hp
1559 0 : call icepack_warnings_add(warnstr)
1560 0 : write(warnstr,*) subname, ' fs = ', &
1561 0 : fs
1562 0 : call icepack_warnings_add(warnstr)
1563 0 : write(warnstr,*) subname, ' fi = ', &
1564 0 : fi
1565 0 : call icepack_warnings_add(warnstr)
1566 0 : write(warnstr,*) subname, ' fp = ', &
1567 0 : fp
1568 0 : call icepack_warnings_add(warnstr)
1569 0 : write(warnstr,*) subname, ' hi = ', &
1570 0 : hi
1571 0 : call icepack_warnings_add(warnstr)
1572 0 : write(warnstr,*) subname, ' alvdr alvdf = ', &
1573 0 : alvdr,alvdf
1574 0 : call icepack_warnings_add(warnstr)
1575 0 : write(warnstr,*) subname, ' alidr alidf = ', &
1576 0 : alidr,alidf
1577 0 : call icepack_warnings_add(warnstr)
1578 0 : write(warnstr,*) subname, ' fswsfc fswint fswthru = ', &
1579 0 : fswsfc,fswint,fswthru
1580 0 : call icepack_warnings_add(warnstr)
1581 0 : swdn = swvdr+swvdf+swidr+swidf
1582 0 : swab = fswsfc+fswint+fswthru
1583 0 : swalb = (1.-swab/(swdn+.0001))
1584 0 : write(warnstr,*) subname, ' swdn swab swalb = ',swdn,swab,swalb
1585 0 : do k = 1, nslyr
1586 0 : write(warnstr,*) subname, ' snow layer k = ', k, &
1587 : ' rhosnw = ', & ! LCOV_EXCL_LINE
1588 : rhosnw(k), & ! LCOV_EXCL_LINE
1589 : ' rsnw = ', & ! LCOV_EXCL_LINE
1590 0 : rsnw(k)
1591 0 : call icepack_warnings_add(warnstr)
1592 : enddo
1593 0 : do k = 1, nslyr
1594 0 : write(warnstr,*) subname, ' snow layer k = ', k, &
1595 0 : ' Sswabs(k) = ', Sswabs(k)
1596 0 : call icepack_warnings_add(warnstr)
1597 : enddo
1598 0 : do k = 1, nilyr
1599 0 : write(warnstr,*) subname, ' sea ice layer k = ', k, &
1600 0 : ' Iswabs(k) = ', Iswabs(k)
1601 0 : call icepack_warnings_add(warnstr)
1602 : enddo
1603 :
1604 : endif ! l_print_point .and. coszen > .01
1605 :
1606 2898172 : end subroutine shortwave_dEdd
1607 :
1608 : !=======================================================================
1609 : !
1610 : ! Evaluate snow/ice/ponded ice inherent optical properties (IOPs), and
1611 : ! then calculate the multiple scattering solution by calling solution_dEdd.
1612 : !
1613 : ! author: Bruce P. Briegleb, NCAR
1614 : ! 2013: E Hunke merged with NCAR version
1615 : ! 2022: E Hunke, T Craig moved data (now module data)
1616 :
1617 3118121 : subroutine compute_dEdd_3bd( &
1618 : klev, klevp, zbio, fnidr, coszen, & ! LCOV_EXCL_LINE
1619 : swvdr, swvdf, swidr, swidf, srftyp, & ! LCOV_EXCL_LINE
1620 : hs, rhosnw, rsnw, hi, hp, & ! LCOV_EXCL_LINE
1621 : fi, aero_mp, alvdr, alvdf, & ! LCOV_EXCL_LINE
1622 : alidr, alidf, fswsfc, fswint, fswthru, & ! LCOV_EXCL_LINE
1623 : fswthru_vdr, fswthru_vdf, & ! LCOV_EXCL_LINE
1624 : fswthru_idr, fswthru_idf, & ! LCOV_EXCL_LINE
1625 3118121 : Sswabs, Iswabs, fswpenl )
1626 :
1627 : integer (kind=int_kind), intent(in) :: &
1628 : klev , & ! number of radiation layers - 1 ! LCOV_EXCL_LINE
1629 : klevp ! number of radiation interfaces - 1
1630 : ! (0 layer is included also)
1631 :
1632 : real (kind=dbl_kind), intent(in) :: &
1633 : fnidr , & ! fraction of direct to total down flux in nir ! LCOV_EXCL_LINE
1634 : coszen, & ! cosine solar zenith angle ! LCOV_EXCL_LINE
1635 : swvdr , & ! shortwave down at surface, visible, direct (W/m^2) ! LCOV_EXCL_LINE
1636 : swvdf , & ! shortwave down at surface, visible, diffuse (W/m^2) ! LCOV_EXCL_LINE
1637 : swidr , & ! shortwave down at surface, near IR, direct (W/m^2) ! LCOV_EXCL_LINE
1638 : swidf ! shortwave down at surface, near IR, diffuse (W/m^2)
1639 :
1640 : integer (kind=int_kind), intent(in) :: &
1641 : srftyp ! surface type over ice: (0=air, 1=snow, 2=pond)
1642 :
1643 : real (kind=dbl_kind), intent(in) :: &
1644 : hs ! snow thickness (m)
1645 :
1646 : real (kind=dbl_kind), dimension (:), intent(in) :: &
1647 : rhosnw, & ! snow density in snow layer (kg/m3) ! LCOV_EXCL_LINE
1648 : rsnw , & ! snow grain radius in snow layer (m) ! LCOV_EXCL_LINE
1649 : zbio , & ! zaerosol + chla shortwave tracers kg/m^3 ! LCOV_EXCL_LINE
1650 : aero_mp ! aerosol mass path in kg/m2
1651 :
1652 : real (kind=dbl_kind), intent(in) :: &
1653 : hi , & ! ice thickness (m) ! LCOV_EXCL_LINE
1654 : hp , & ! pond depth (m) ! LCOV_EXCL_LINE
1655 : fi ! snow/bare ice fractional coverage (0 to 1)
1656 :
1657 : real (kind=dbl_kind), intent(inout) :: &
1658 : alvdr , & ! visible, direct, albedo (fraction) ! LCOV_EXCL_LINE
1659 : alvdf , & ! visible, diffuse, albedo (fraction) ! LCOV_EXCL_LINE
1660 : alidr , & ! near-ir, direct, albedo (fraction) ! LCOV_EXCL_LINE
1661 : alidf , & ! near-ir, diffuse, albedo (fraction) ! LCOV_EXCL_LINE
1662 : fswsfc, & ! SW absorbed at snow/bare ice/pondedi ice surface (W m-2) ! LCOV_EXCL_LINE
1663 : fswint, & ! SW interior absorption (below surface, above ocean,W m-2) ! LCOV_EXCL_LINE
1664 : fswthru ! SW through snow/bare ice/ponded ice into ocean (W m-2)
1665 :
1666 : real (kind=dbl_kind), intent(inout) :: &
1667 : fswthru_vdr, & ! vis dir SW through snow/bare ice/ponded ice into ocean (W m-2) ! LCOV_EXCL_LINE
1668 : fswthru_vdf, & ! vis dif SW through snow/bare ice/ponded ice into ocean (W m-2) ! LCOV_EXCL_LINE
1669 : fswthru_idr, & ! nir dir SW through snow/bare ice/ponded ice into ocean (W m-2) ! LCOV_EXCL_LINE
1670 : fswthru_idf ! nir dif SW through snow/bare ice/ponded ice into ocean (W m-2)
1671 :
1672 : real (kind=dbl_kind), dimension (:), intent(inout) :: &
1673 : fswpenl, & ! visible SW entering ice layers (W m-2) ! LCOV_EXCL_LINE
1674 : Sswabs , & ! SW absorbed in snow layer (W m-2) ! LCOV_EXCL_LINE
1675 : Iswabs ! SW absorbed in ice layer (W m-2)
1676 :
1677 : !-----------------------------------------------------------------------
1678 : !
1679 : ! Set up optical property profiles, based on snow, sea ice and ponded
1680 : ! ice IOPs from:
1681 : !
1682 : ! Briegleb, B. P., and B. Light (2007): A Delta-Eddington Multiple
1683 : ! Scattering Parameterization for Solar Radiation in the Sea Ice
1684 : ! Component of the Community Climate System Model, NCAR Technical
1685 : ! Note NCAR/TN-472+STR February 2007
1686 : !
1687 : ! Computes column Delta-Eddington radiation solution for specific
1688 : ! surface type: either snow over sea ice, bare sea ice, or ponded sea ice.
1689 : !
1690 : ! Divides solar spectrum into 3 intervals: 0.2-0.7, 0.7-1.19, and
1691 : ! 1.19-5.0 micro-meters. The latter two are added (using an assumed
1692 : ! partition of incident shortwave in the 0.7-5.0 micro-meter band between
1693 : ! the 0.7-1.19 and 1.19-5.0 micro-meter band) to give the final output
1694 : ! of 0.2-0.7 visible and 0.7-5.0 near-infrared albedos and fluxes.
1695 : !
1696 : ! Specifies vertical layer optical properties based on input snow depth,
1697 : ! density and grain radius, along with ice and pond depths, then computes
1698 : ! layer by layer Delta-Eddington reflectivity, transmissivity and combines
1699 : ! layers (done by calling routine solution_dEdd). Finally, surface albedos
1700 : ! and internal fluxes/flux divergences are evaluated.
1701 : !
1702 : ! Description of the level and layer index conventions. This is
1703 : ! for the standard case of one snow layer and four sea ice layers.
1704 : !
1705 : ! Please read the following; otherwise, there is 99.9% chance you
1706 : ! will be confused about indices at some point in time........ :)
1707 : !
1708 : ! CICE4.0 snow treatment has one snow layer above the sea ice. This
1709 : ! snow layer has finite heat capacity, so that surface absorption must
1710 : ! be distinguished from internal. The Delta-Eddington solar radiation
1711 : ! thus adds extra surface scattering layers to both snow and sea ice.
1712 : ! Note that in the following, we assume a fixed vertical layer structure
1713 : ! for the radiation calculation. In other words, we always have the
1714 : ! structure shown below for one snow and four sea ice layers, but for
1715 : ! ponded ice the pond fills "snow" layer 1 over the sea ice, and for
1716 : ! bare sea ice the top layers over sea ice are treated as transparent air.
1717 : !
1718 : ! SSL = surface scattering layer for either snow or sea ice
1719 : ! DL = drained layer for sea ice immediately under sea ice SSL
1720 : ! INT = interior layers for sea ice below the drained layer.
1721 : !
1722 : ! Notice that the radiation level starts with 0 at the top. Thus,
1723 : ! the total number radiation layers is klev+1, where klev is the
1724 : ! sum of nslyr, the number of CCSM snow layers, and nilyr, the
1725 : ! number of CCSM sea ice layers, plus the sea ice SSL:
1726 : ! klev = 1 + nslyr + nilyr
1727 : !
1728 : ! For the standard case illustrated below, nslyr=1, nilyr=4,
1729 : ! and klev=6, with the number of layer interfaces klevp=klev+1.
1730 : ! Layer interfaces are the surfaces on which reflectivities,
1731 : ! transmissivities and fluxes are evaluated.
1732 : !
1733 : ! CCSM3 Sea Ice Model Delta-Eddington Solar Radiation
1734 : ! Layers and Interfaces
1735 : ! Layer Index Interface Index
1736 : ! --------------------- --------------------- 0
1737 : ! 0 \\\ snow SSL \\\
1738 : ! snow layer 1 --------------------- 1
1739 : ! 1 rest of snow layer
1740 : ! +++++++++++++++++++++ +++++++++++++++++++++ 2
1741 : ! 2 \\\ sea ice SSL \\\
1742 : ! sea ice layer 1 --------------------- 3
1743 : ! 3 sea ice DL
1744 : ! --------------------- --------------------- 4
1745 : !
1746 : ! sea ice layer 2 4 sea ice INT
1747 : !
1748 : ! --------------------- --------------------- 5
1749 : !
1750 : ! sea ice layer 3 5 sea ice INT
1751 : !
1752 : ! --------------------- --------------------- 6
1753 : !
1754 : ! sea ice layer 4 6 sea ice INT
1755 : !
1756 : ! --------------------- --------------------- 7
1757 : !
1758 : ! When snow lies over sea ice, the radiation absorbed in the
1759 : ! snow SSL is used for surface heating, and that in the rest
1760 : ! of the snow layer for its internal heating. For sea ice in
1761 : ! this case, all of the radiant heat absorbed in both the
1762 : ! sea ice SSL and the DL are used for sea ice layer 1 heating.
1763 : !
1764 : ! When pond lies over sea ice, and for bare sea ice, all of the
1765 : ! radiant heat absorbed within and above the sea ice SSL is used
1766 : ! for surface heating, and that absorbed in the sea ice DL is
1767 : ! used for sea ice layer 1 heating.
1768 : !
1769 : ! Basically, vertical profiles of the layer extinction optical depth (tau),
1770 : ! single scattering albedo (w0) and asymmetry parameter (g) are required over
1771 : ! the klev+1 layers, where klev+1 = 2 + nslyr + nilyr. All of the surface type
1772 : ! information and snow/ice iop properties are evaulated in this routine, so
1773 : ! the tau,w0,g profiles can be passed to solution_dEdd for multiple scattering
1774 : ! evaluation. Snow, bare ice and ponded ice iops are contained in data arrays
1775 : ! in this routine.
1776 : !
1777 : !-----------------------------------------------------------------------
1778 :
1779 : ! local variables
1780 :
1781 : integer (kind=int_kind) :: &
1782 : k , & ! level index ! LCOV_EXCL_LINE
1783 : ns , & ! spectral index ! LCOV_EXCL_LINE
1784 : nr , & ! index for grain radius tables ! LCOV_EXCL_LINE
1785 : ki , & ! index for internal absorption ! LCOV_EXCL_LINE
1786 : km , & ! k starting index for snow, sea ice internal absorption ! LCOV_EXCL_LINE
1787 : kp , & ! k+1 or k+2 index for snow, sea ice internal absorption ! LCOV_EXCL_LINE
1788 : ksrf , & ! level index for surface absorption ! LCOV_EXCL_LINE
1789 : ksnow , & ! level index for snow density and grain size ! LCOV_EXCL_LINE
1790 : kii ! level starting index for sea ice (nslyr+1)
1791 :
1792 : real (kind=dbl_kind) :: &
1793 : avdr , & ! visible albedo, direct (fraction) ! LCOV_EXCL_LINE
1794 : avdf , & ! visible albedo, diffuse (fraction) ! LCOV_EXCL_LINE
1795 : aidr , & ! near-ir albedo, direct (fraction) ! LCOV_EXCL_LINE
1796 1823518 : aidf ! near-ir albedo, diffuse (fraction)
1797 :
1798 : real (kind=dbl_kind) :: &
1799 : fsfc , & ! shortwave absorbed at snow/bare ice/ponded ice surface (W m-2) ! LCOV_EXCL_LINE
1800 : fint , & ! shortwave absorbed in interior (W m-2) ! LCOV_EXCL_LINE
1801 : fthru , & ! shortwave through snow/bare ice/ponded ice to ocean (W/m^2) ! LCOV_EXCL_LINE
1802 : fthruvdr, & ! vis dir shortwave through snow/bare ice/ponded ice to ocean (W/m^2) ! LCOV_EXCL_LINE
1803 : fthruvdf, & ! vis dif shortwave through snow/bare ice/ponded ice to ocean (W/m^2) ! LCOV_EXCL_LINE
1804 : fthruidr, & ! nir dir shortwave through snow/bare ice/ponded ice to ocean (W/m^2) ! LCOV_EXCL_LINE
1805 1823518 : fthruidf ! nir dif shortwave through snow/bare ice/ponded ice to ocean (W/m^2)
1806 :
1807 : real (kind=dbl_kind), dimension(nslyr) :: &
1808 6236242 : Sabs ! shortwave absorbed in snow layer (W m-2)
1809 :
1810 : real (kind=dbl_kind), dimension(nilyr) :: &
1811 17177350 : Iabs ! shortwave absorbed in ice layer (W m-2)
1812 :
1813 : real (kind=dbl_kind), dimension(nilyr+1) :: &
1814 19000868 : fthrul ! shortwave through to ice layers (W m-2)
1815 :
1816 : real (kind=dbl_kind), dimension (nspint_3bd) :: &
1817 7294072 : wghtns ! spectral weights
1818 :
1819 : real (kind=dbl_kind), parameter :: &
1820 : cp67 = 0.67_dbl_kind, & ! nir band weight parameter ! LCOV_EXCL_LINE
1821 : cp78 = 0.78_dbl_kind, & ! nir band weight parameter ! LCOV_EXCL_LINE
1822 : cp01 = 0.01_dbl_kind ! for ocean visible albedo
1823 :
1824 : real (kind=dbl_kind), dimension (0:klev) :: &
1825 : tau , & ! layer extinction optical depth ! LCOV_EXCL_LINE
1826 : w0 , & ! layer single scattering albedo ! LCOV_EXCL_LINE
1827 22647904 : g ! layer asymmetry parameter
1828 :
1829 : ! following arrays are defined at model interfaces; 0 is the top of the
1830 : ! layer above the sea ice; klevp is the sea ice/ocean interface.
1831 : real (kind=dbl_kind), dimension (0:klevp) :: &
1832 : trndir , & ! solar beam down transmission from top ! LCOV_EXCL_LINE
1833 : trntdr , & ! total transmission to direct beam for layers above ! LCOV_EXCL_LINE
1834 : trndif , & ! diffuse transmission to diffuse beam for layers above ! LCOV_EXCL_LINE
1835 : rupdir , & ! reflectivity to direct radiation for layers below ! LCOV_EXCL_LINE
1836 : rupdif , & ! reflectivity to diffuse radiation for layers below ! LCOV_EXCL_LINE
1837 24471422 : rdndif ! reflectivity to diffuse radiation for layers above
1838 :
1839 : real (kind=dbl_kind), dimension (0:klevp) :: &
1840 : dfdir , & ! down-up flux at interface due to direct beam at top surface ! LCOV_EXCL_LINE
1841 25766025 : dfdif ! down-up flux at interface due to diffuse beam at top surface
1842 :
1843 : real (kind=dbl_kind) :: &
1844 : refk , & ! interface k multiple scattering term ! LCOV_EXCL_LINE
1845 : delr , & ! snow grain radius interpolation parameter ! LCOV_EXCL_LINE
1846 : ! inherent optical properties (iop) for snow
1847 1823518 : Qs , & ! Snow extinction efficiency
1848 : ks , & ! Snow mass extinction coefficient (m^2/kg) ! echmod - CHECK units and usage ! LCOV_EXCL_LINE
1849 : ws , & ! Snow single scattering albedo ! LCOV_EXCL_LINE
1850 1823518 : gs ! Snow asymmetry parameter
1851 :
1852 : real (kind=dbl_kind), dimension(nslyr) :: &
1853 6236242 : frsnw ! snow grain radius in snow layer * adjustment factor (m)
1854 :
1855 : ! ice and ponded ice IOPs, allowing for tuning
1856 : ! modifications of the above "_mn" value
1857 : real (kind=dbl_kind), dimension (nspint_3bd) :: &
1858 : ki_ssl , & ! Surface-scattering-layer ice extinction coefficient (/m) ! LCOV_EXCL_LINE
1859 : wi_ssl , & ! Surface-scattering-layer ice single scattering albedo ! LCOV_EXCL_LINE
1860 : gi_ssl , & ! Surface-scattering-layer ice asymmetry parameter ! LCOV_EXCL_LINE
1861 : ki_dl , & ! Drained-layer ice extinction coefficient (/m) ! LCOV_EXCL_LINE
1862 : wi_dl , & ! Drained-layer ice single scattering albedo ! LCOV_EXCL_LINE
1863 : gi_dl , & ! Drained-layer ice asymmetry parameter ! LCOV_EXCL_LINE
1864 : ki_int , & ! Interior-layer ice extinction coefficient (/m) ! LCOV_EXCL_LINE
1865 : wi_int , & ! Interior-layer ice single scattering albedo ! LCOV_EXCL_LINE
1866 : gi_int , & ! Interior-layer ice asymmetry parameter ! LCOV_EXCL_LINE
1867 : ki_p_ssl, & ! Ice under pond srf scat layer extinction coefficient (/m) ! LCOV_EXCL_LINE
1868 : wi_p_ssl, & ! Ice under pond srf scat layer single scattering albedo ! LCOV_EXCL_LINE
1869 : gi_p_ssl, & ! Ice under pond srf scat layer asymmetry parameter ! LCOV_EXCL_LINE
1870 : ki_p_int, & ! Ice under pond extinction coefficient (/m) ! LCOV_EXCL_LINE
1871 : wi_p_int, & ! Ice under pond single scattering albedo ! LCOV_EXCL_LINE
1872 7294072 : gi_p_int ! Ice under pond asymmetry parameter
1873 :
1874 : real (kind=dbl_kind), dimension(0:klev) :: &
1875 22647904 : dzk ! layer thickness
1876 :
1877 : real (kind=dbl_kind) :: &
1878 : dz , & ! snow, sea ice or pond water layer thickness ! LCOV_EXCL_LINE
1879 : dz_ssl , & ! snow or sea ice surface scattering layer thickness ! LCOV_EXCL_LINE
1880 1823518 : fs ! scaling factor to reduce (nilyr<4) or increase (nilyr>4) DL
1881 : ! extinction coefficient to maintain DL optical depth constant
1882 : ! with changing number of sea ice layers, to approximately
1883 : ! conserve computed albedo for constant physical depth of sea
1884 : ! ice when the number of sea ice layers vary
1885 :
1886 : real (kind=dbl_kind) :: &
1887 : sig , & ! scattering coefficient for tuning ! LCOV_EXCL_LINE
1888 : kabs , & ! absorption coefficient for tuning ! LCOV_EXCL_LINE
1889 1823518 : sigp ! modified scattering coefficient for tuning
1890 :
1891 : real (kind=dbl_kind), dimension(nspint_3bd, 0:klev) :: &
1892 : kabs_chl, & ! absorption coefficient for chlorophyll (/m) ! LCOV_EXCL_LINE
1893 : tzaer , & ! total aerosol extinction optical depth ! LCOV_EXCL_LINE
1894 : wzaer , & ! total aerosol single scatter albedo ! LCOV_EXCL_LINE
1895 77353444 : gzaer ! total aerosol asymmetry parameter
1896 :
1897 : real (kind=dbl_kind) :: &
1898 : albodr , & ! spectral ocean albedo to direct rad ! LCOV_EXCL_LINE
1899 1823518 : albodf ! spectral ocean albedo to diffuse rad
1900 :
1901 : ! for melt pond transition to bare sea ice for small pond depths
1902 : real (kind=dbl_kind) :: &
1903 : sig_i , & ! ice scattering coefficient (/m) ! LCOV_EXCL_LINE
1904 : sig_p , & ! pond scattering coefficient (/m) ! LCOV_EXCL_LINE
1905 1823518 : kext ! weighted extinction coefficient (/m)
1906 :
1907 : ! aerosol optical properties from Mark Flanner, 26 June 2008
1908 : ! order assumed: hydrophobic black carbon, hydrophilic black carbon,
1909 : ! four dust aerosols by particle size range:
1910 : ! dust1(.05-0.5 micron), dust2(0.5-1.25 micron),
1911 : ! dust3(1.25-2.5 micron), dust4(2.5-5.0 micron)
1912 : ! spectral bands same as snow/sea ice: (0.3-0.7 micron, 0.7-1.19 micron
1913 : ! and 1.19-5.0 micron in wavelength)
1914 :
1915 : integer (kind=int_kind) :: &
1916 : na , n ! aerosol index
1917 :
1918 : real (kind=dbl_kind) :: &
1919 : taer , & ! total aerosol extinction optical depth ! LCOV_EXCL_LINE
1920 : waer , & ! total aerosol single scatter albedo ! LCOV_EXCL_LINE
1921 : gaer , & ! total aerosol asymmetry parameter ! LCOV_EXCL_LINE
1922 : swdr , & ! shortwave down at surface, direct (W/m^2) ! LCOV_EXCL_LINE
1923 : swdf , & ! shortwave down at surface, diffuse (W/m^2) ! LCOV_EXCL_LINE
1924 : rnilyr , & ! 1/real(nilyr) ! LCOV_EXCL_LINE
1925 : rnslyr , & ! 1/real(nslyr) ! LCOV_EXCL_LINE
1926 : rns , & ! real(ns) ! LCOV_EXCL_LINE
1927 1823518 : tmp_0, tmp_ks, tmp_kl ! temporary variables
1928 :
1929 : integer(kind=int_kind), dimension(0:klev) :: &
1930 : k_bcini , & ! index ! LCOV_EXCL_LINE
1931 : k_bcins , & ! = 2 hardwired ! LCOV_EXCL_LINE
1932 4941639 : k_bcexs ! = 2 hardwired
1933 :
1934 : real(kind=dbl_kind):: &
1935 1823518 : tmp_gs, tmp1 ! temporary variables
1936 :
1937 : real (kind=dbl_kind), parameter :: &
1938 : fr_max = 1.00_dbl_kind, & ! snow grain adjustment factor max ! LCOV_EXCL_LINE
1939 : fr_min = 0.80_dbl_kind, & ! snow grain adjustment factor min ! LCOV_EXCL_LINE
1940 : ! tuning parameters
1941 : ! ice and pond scat coeff fractional change for +- one-sigma in albedo
1942 : fp_ice = 0.15_dbl_kind, & ! ice fraction of scat coeff for + stn dev in alb
1943 : fm_ice = 0.15_dbl_kind, & ! ice fraction of scat coeff for - stn dev in alb ! LCOV_EXCL_LINE
1944 : fp_pnd = 2.00_dbl_kind, & ! ponded ice fraction of scat coeff for + stn dev in alb ! LCOV_EXCL_LINE
1945 : fm_pnd = 0.50_dbl_kind ! ponded ice fraction of scat coeff for - stn dev in alb
1946 :
1947 : real (kind=dbl_kind), parameter :: & ! chla-specific absorption coefficient
1948 : kchl_tab = p01 ! 0.0023-0.0029 Perovich 1993, also 0.0067 m^2 (mg Chl)^-1
1949 : ! found values of 0.006 to 0.023 m^2/ mg (676 nm) Neukermans 2014
1950 : ! and averages over the 300-700nm of 0.0075 m^2/mg in ice Fritsen (2011)
1951 : ! at 440nm values as high as 0.2 m^2/mg in under ice bloom (Balch 2014)
1952 : ! Grenfell 1991 uses 0.004 (m^2/mg) which is (0.0078 * spectral weighting)
1953 : ! chlorophyll mass extinction cross section (m^2/mg chla)
1954 :
1955 : character(len=*),parameter :: subname='(compute_dEdd_3bd)'
1956 :
1957 : !-----------------------------------------------------------------------
1958 : ! Initialize and tune bare ice/ponded ice iops
1959 :
1960 34299331 : k_bcini(:) = 0
1961 34299331 : k_bcins(:) = 0
1962 34299331 : k_bcexs(:) = 0
1963 :
1964 3118121 : rnilyr = c1/real(nilyr,kind=dbl_kind)
1965 3118121 : rnslyr = c1/real(nslyr,kind=dbl_kind)
1966 3118121 : kii = nslyr + 1
1967 :
1968 : ! initialize albedos and fluxes to 0
1969 28063089 : fthrul = c0
1970 24944968 : Iabs = c0
1971 127842961 : kabs_chl(:,:) = c0
1972 127842961 : tzaer (:,:) = c0
1973 127842961 : wzaer (:,:) = c0
1974 127842961 : gzaer (:,:) = c0
1975 :
1976 3118121 : avdr = c0
1977 3118121 : avdf = c0
1978 3118121 : aidr = c0
1979 3118121 : aidf = c0
1980 3118121 : fsfc = c0
1981 3118121 : fint = c0
1982 3118121 : fthru = c0
1983 3118121 : fthruvdr = c0
1984 3118121 : fthruvdf = c0
1985 3118121 : fthruidr = c0
1986 3118121 : fthruidf = c0
1987 :
1988 : ! spectral weights 2 (0.7-1.19 micro-meters) and 3 (1.19-5.0 micro-meters)
1989 : ! are chosen based on 1D calculations using ratio of direct to total
1990 : ! near-infrared solar (0.7-5.0 micro-meter) which indicates clear/cloudy
1991 : ! conditions: more cloud, the less 1.19-5.0 relative to the
1992 : ! 0.7-1.19 micro-meter due to cloud absorption.
1993 3118121 : wghtns(1) = c1
1994 3118121 : wghtns(2) = cp67 + (cp78-cp67)*(c1-fnidr)
1995 3118121 : wghtns(3) = c1 - wghtns(2)
1996 :
1997 : ! find snow grain adjustment factor, dependent upon clear/overcast sky
1998 : ! estimate. comparisons with SNICAR show better agreement with DE when
1999 : ! this factor is included (clear sky near 1 and overcast near 0.8 give
2000 : ! best agreement). Multiply by rnsw here for efficiency.
2001 6236242 : do k = 1, nslyr
2002 3118121 : frsnw(k) = (fr_max*fnidr + fr_min*(c1-fnidr))*rsnw(k)
2003 6236242 : Sabs(k) = c0
2004 : enddo
2005 :
2006 : ! layer thicknesses
2007 : ! snow
2008 3118121 : dz = hs*rnslyr
2009 : ! for small enough snow thickness, ssl thickness half of top snow layer
2010 : !ech: note this is highly resolution dependent!
2011 3118121 : dzk(0) = min(hs_ssl, dz/c2)
2012 3118121 : dzk(1) = dz - dzk(0)
2013 3118121 : if (nslyr > 1) then
2014 0 : do k = 2, nslyr
2015 0 : dzk(k) = dz
2016 : enddo
2017 : endif
2018 :
2019 : ! ice
2020 3118121 : dz = hi*rnilyr
2021 : ! empirical reduction in sea ice ssl thickness for ice thinner than 1.5m;
2022 : ! factor of 30 gives best albedo comparison with limited observations
2023 3118121 : dz_ssl = hi_ssl
2024 : !ech: note hardwired parameters
2025 : ! if( hi < 1.5_dbl_kind ) dz_ssl = hi/30._dbl_kind
2026 3118121 : dz_ssl = min(hi_ssl, hi/30._dbl_kind)
2027 : ! set sea ice ssl thickness to half top layer if sea ice thin enough
2028 : !ech: note this is highly resolution dependent!
2029 3118121 : dz_ssl = min(dz_ssl, dz/c2)
2030 :
2031 3118121 : dzk(kii) = dz_ssl
2032 3118121 : dzk(kii+1) = dz - dz_ssl
2033 3118121 : if (kii+2 <= klev) then
2034 21826847 : do k = kii+2, klev
2035 21826847 : dzk(k) = dz
2036 : enddo
2037 : endif
2038 :
2039 : ! adjust sea ice iops with tuning parameters; tune only the
2040 : ! scattering coefficient by factors of R_ice, R_pnd, where
2041 : ! R values of +1 correspond approximately to +1 sigma changes in albedo, and
2042 : ! R values of -1 correspond approximately to -1 sigma changes in albedo
2043 : ! Note: the albedo change becomes non-linear for R values > +1 or < -1
2044 3118121 : if( R_ice >= c0 ) then
2045 12472484 : do ns = 1, nspint_3bd
2046 9354363 : sigp = ki_ssl_mn_3bd(ns)*wi_ssl_mn_3bd(ns)*(c1+fp_ice*R_ice)
2047 9354363 : ki_ssl(ns) = sigp+ki_ssl_mn_3bd(ns)*(c1-wi_ssl_mn_3bd(ns))
2048 9354363 : wi_ssl(ns) = sigp/ki_ssl(ns)
2049 9354363 : gi_ssl(ns) = gi_ssl_mn_3bd(ns)
2050 :
2051 9354363 : sigp = ki_dl_mn_3bd(ns)*wi_dl_mn_3bd(ns)*(c1+fp_ice*R_ice)
2052 9354363 : ki_dl(ns) = sigp+ki_dl_mn_3bd(ns)*(c1-wi_dl_mn_3bd(ns))
2053 9354363 : wi_dl(ns) = sigp/ki_dl(ns)
2054 9354363 : gi_dl(ns) = gi_dl_mn_3bd(ns)
2055 :
2056 9354363 : sigp = ki_int_mn_3bd(ns)*wi_int_mn_3bd(ns)*(c1+fp_ice*R_ice)
2057 9354363 : ki_int(ns) = sigp+ki_int_mn_3bd(ns)*(c1-wi_int_mn_3bd(ns))
2058 9354363 : wi_int(ns) = sigp/ki_int(ns)
2059 12472484 : gi_int(ns) = gi_int_mn_3bd(ns)
2060 : enddo
2061 : else !if( R_ice < c0 ) then
2062 0 : do ns = 1, nspint_3bd
2063 0 : sigp = ki_ssl_mn_3bd(ns)*wi_ssl_mn_3bd(ns)*(c1+fm_ice*R_ice)
2064 0 : sigp = max(sigp, c0)
2065 0 : ki_ssl(ns) = sigp+ki_ssl_mn_3bd(ns)*(c1-wi_ssl_mn_3bd(ns))
2066 0 : wi_ssl(ns) = sigp/ki_ssl(ns)
2067 0 : gi_ssl(ns) = gi_ssl_mn_3bd(ns)
2068 :
2069 0 : sigp = ki_dl_mn_3bd(ns)*wi_dl_mn_3bd(ns)*(c1+fm_ice*R_ice)
2070 0 : sigp = max(sigp, c0)
2071 0 : ki_dl(ns) = sigp+ki_dl_mn_3bd(ns)*(c1-wi_dl_mn_3bd(ns))
2072 0 : wi_dl(ns) = sigp/ki_dl(ns)
2073 0 : gi_dl(ns) = gi_dl_mn_3bd(ns)
2074 :
2075 0 : sigp = ki_int_mn_3bd(ns)*wi_int_mn_3bd(ns)*(c1+fm_ice*R_ice)
2076 0 : sigp = max(sigp, c0)
2077 0 : ki_int(ns) = sigp+ki_int_mn_3bd(ns)*(c1-wi_int_mn_3bd(ns))
2078 0 : wi_int(ns) = sigp/ki_int(ns)
2079 0 : gi_int(ns) = gi_int_mn_3bd(ns)
2080 : enddo
2081 : endif ! adjust ice iops
2082 :
2083 : ! adjust ponded ice iops with tuning parameters
2084 3118121 : if( R_pnd >= c0 ) then
2085 12472484 : do ns = 1, nspint_3bd
2086 9354363 : sigp = ki_p_ssl_mn(ns)*wi_p_ssl_mn(ns)*(c1+fp_pnd*R_pnd)
2087 9354363 : ki_p_ssl(ns) = sigp+ki_p_ssl_mn(ns)*(c1-wi_p_ssl_mn(ns))
2088 9354363 : wi_p_ssl(ns) = sigp/ki_p_ssl(ns)
2089 9354363 : gi_p_ssl(ns) = gi_p_ssl_mn(ns)
2090 :
2091 9354363 : sigp = ki_p_int_mn(ns)*wi_p_int_mn(ns)*(c1+fp_pnd*R_pnd)
2092 9354363 : ki_p_int(ns) = sigp+ki_p_int_mn(ns)*(c1-wi_p_int_mn(ns))
2093 9354363 : wi_p_int(ns) = sigp/ki_p_int(ns)
2094 12472484 : gi_p_int(ns) = gi_p_int_mn(ns)
2095 : enddo
2096 : else !if( R_pnd < c0 ) then
2097 0 : do ns = 1, nspint_3bd
2098 0 : sigp = ki_p_ssl_mn(ns)*wi_p_ssl_mn(ns)*(c1+fm_pnd*R_pnd)
2099 0 : sigp = max(sigp, c0)
2100 0 : ki_p_ssl(ns) = sigp+ki_p_ssl_mn(ns)*(c1-wi_p_ssl_mn(ns))
2101 0 : wi_p_ssl(ns) = sigp/ki_p_ssl(ns)
2102 0 : gi_p_ssl(ns) = gi_p_ssl_mn(ns)
2103 :
2104 0 : sigp = ki_p_int_mn(ns)*wi_p_int_mn(ns)*(c1+fm_pnd*R_pnd)
2105 0 : sigp = max(sigp, c0)
2106 0 : ki_p_int(ns) = sigp+ki_p_int_mn(ns)*(c1-wi_p_int_mn(ns))
2107 0 : wi_p_int(ns) = sigp/ki_p_int(ns)
2108 0 : gi_p_int(ns) = gi_p_int_mn(ns)
2109 : enddo
2110 : endif ! adjust ponded ice iops
2111 :
2112 : ! use srftyp to determine interface index of surface absorption
2113 3118121 : if (srftyp == 1) then
2114 : ! snow covered sea ice
2115 2448232 : ksrf = 1
2116 : else
2117 : ! bare sea ice or ponded ice
2118 669889 : ksrf = nslyr + 2
2119 : endif
2120 :
2121 3118121 : if (tr_bgc_N .and. dEdd_algae) then ! compute kabs_chl for chlorophyll
2122 0 : do k = 0, klev
2123 0 : kabs_chl(1,k) = kchl_tab*zbio(nlt_chl_sw+k)
2124 : enddo
2125 : else
2126 3118121 : k = klev
2127 3118121 : kabs_chl(1,k) = kalg*(0.50_dbl_kind/dzk(k))
2128 : endif ! kabs_chl
2129 :
2130 : ! aerosols
2131 3118121 : if (modal_aero) then
2132 0 : do k = 0, klev
2133 0 : if (k < nslyr+1) then ! define indices for snow layer
2134 : ! use top rsnw, rhosnw for snow ssl and rest of top layer
2135 : ! Cheng: note that aerosol IOPs are related to snow grain radius.
2136 : ! CICE adjusted snow grain radius rsnw to frsnw in the original 3-band
2137 : ! scheme, while for SNICAR the snow grain radius is used directly.
2138 0 : ksnow = k - min(k-1,0)
2139 0 : tmp_gs = frsnw(ksnow)
2140 :
2141 : ! grain size index
2142 0 : if (tmp_gs < 125._dbl_kind) then
2143 0 : tmp1 = tmp_gs/50._dbl_kind
2144 0 : k_bcini(k) = nint(tmp1)
2145 0 : elseif (tmp_gs < 175._dbl_kind) then
2146 0 : k_bcini(k) = 2
2147 : else
2148 0 : tmp1 = (tmp_gs/250._dbl_kind) + c2
2149 0 : k_bcini(k) = nint(tmp1)
2150 : endif
2151 : else ! use the largest snow grain size for ice
2152 0 : k_bcini(k) = 8
2153 : endif
2154 : ! Set index corresponding to BC effective radius. Here,
2155 : ! asssume constant BC effective radius of 100nm
2156 : ! (corresponding to index 2)
2157 0 : k_bcins(k) = 2 ! hardwired
2158 0 : k_bcexs(k) = 2
2159 :
2160 : ! check bounds
2161 0 : if (k_bcini(k) < 1) k_bcini(k) = 1
2162 0 : if (k_bcini(k) > 8) k_bcini(k) = 8
2163 : ! if (k_bcins(k) < 1) k_bcins(k) = 1 ! hardwired
2164 : ! if (k_bcins(k) > 10) k_bcins(k) = 10
2165 : ! if (k_bcexs(k) < 1) k_bcexs(k) = 1
2166 : ! if (k_bcexs(k) > 10) k_bcexs(k) = 10
2167 : enddo ! k
2168 :
2169 0 : if (tr_zaero .and. dEdd_algae) then ! compute kzaero for chlorophyll
2170 0 : do n = 1, n_zaero
2171 0 : if (n == 1) then ! interstitial BC
2172 0 : do k = 0, klev
2173 0 : do ns = 1, nspint_3bd ! not weighted by aice
2174 0 : tzaer(ns,k) = tzaer (ns,k) &
2175 : + kaer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2176 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2177 0 : wzaer(ns,k) = wzaer (ns,k) &
2178 : + kaer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2179 : * waer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2180 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2181 0 : gzaer(ns,k) = gzaer (ns,k) &
2182 : + kaer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2183 : * waer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2184 : * gaer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2185 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2186 : enddo
2187 : enddo
2188 0 : elseif (n==2) then ! within-ice BC
2189 0 : do k = 0, klev
2190 0 : do ns = 1, nspint_3bd
2191 0 : tzaer(ns,k) = tzaer (ns,k) &
2192 : + kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2193 : * bcenh_3bd(ns,k_bcins(k),k_bcini(k)) & ! LCOV_EXCL_LINE
2194 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2195 0 : wzaer(ns,k) = wzaer (ns,k) &
2196 : + kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2197 : * waer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2198 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2199 0 : gzaer(ns,k) = gzaer (ns,k) &
2200 : + kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2201 : * waer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2202 : * gaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2203 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2204 : enddo
2205 : enddo
2206 : else ! dust
2207 0 : do k = 0, klev
2208 0 : do ns = 1,nspint_3bd ! not weighted by aice
2209 0 : tzaer(ns,k) = tzaer (ns,k) &
2210 : + kaer_3bd(ns,n) & ! LCOV_EXCL_LINE
2211 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2212 0 : wzaer(ns,k) = wzaer (ns,k) &
2213 : + kaer_3bd(ns,n) & ! LCOV_EXCL_LINE
2214 : * waer_3bd(ns,n) & ! LCOV_EXCL_LINE
2215 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2216 0 : gzaer(ns,k) = gzaer (ns,k) &
2217 : + kaer_3bd(ns,n) & ! LCOV_EXCL_LINE
2218 : * waer_3bd(ns,n) & ! LCOV_EXCL_LINE
2219 : * gaer_3bd(ns,n) & ! LCOV_EXCL_LINE
2220 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2221 : enddo ! nspint
2222 : enddo ! k
2223 : endif ! n
2224 : enddo ! n_zaero
2225 : endif ! tr_zaero and dEdd_algae
2226 :
2227 : else ! Bulk aerosol treatment
2228 3118121 : if (tr_zaero .and. dEdd_algae) then ! compute kzaero for chlorophyll
2229 0 : do n = 1, n_zaero ! multiply by aice?
2230 0 : do k = 0, klev
2231 0 : do ns = 1, nspint_3bd ! not weighted by aice
2232 0 : tzaer(ns,k) = tzaer (ns,k) &
2233 : + kaer_3bd(ns,n) & ! LCOV_EXCL_LINE
2234 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2235 0 : wzaer(ns,k) = wzaer (ns,k) &
2236 : + kaer_3bd(ns,n) & ! LCOV_EXCL_LINE
2237 : * waer_3bd(ns,n) & ! LCOV_EXCL_LINE
2238 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2239 0 : gzaer(ns,k) = gzaer (ns,k) &
2240 : + kaer_3bd(ns,n) & ! LCOV_EXCL_LINE
2241 : * waer_3bd(ns,n) & ! LCOV_EXCL_LINE
2242 : * gaer_3bd(ns,n) & ! LCOV_EXCL_LINE
2243 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
2244 : enddo ! nspint
2245 : enddo ! k
2246 : enddo ! n
2247 : endif ! tr_zaero
2248 : endif ! modal_aero
2249 :
2250 : !-----------------------------------------------------------------------
2251 :
2252 : ! begin spectral loop
2253 : !echmod - split this loop for efficiency, if possible (move conditionals outside of the loop)
2254 12472484 : do ns = 1, nspint_3bd
2255 :
2256 : ! set optical properties of air/snow/pond overlying sea ice
2257 : ! air
2258 9354363 : if (srftyp == 0 ) then
2259 2900970 : do k=0,nslyr
2260 1933980 : tau(k) = c0
2261 1933980 : w0(k) = c0
2262 2900970 : g(k) = c0
2263 : enddo
2264 : ! snow
2265 8387373 : elseif (srftyp == 1 ) then
2266 : ! interpolate snow iops using input snow grain radius,
2267 : ! snow density and tabular data
2268 :
2269 22034088 : do k = 0, nslyr
2270 : ! use top rsnw, rhosnw for snow ssl and rest of top layer
2271 14689392 : ksnow = k - min(k-1,0)
2272 : ! find snow iops using input snow density and snow grain radius:
2273 14689392 : if (frsnw(ksnow) < rsnw_tab(1)) then
2274 0 : Qs = Qs_tab(ns,1)
2275 0 : ws = ws_tab(ns,1)
2276 0 : gs = gs_tab(ns,1)
2277 14689392 : elseif (frsnw(ksnow) >= rsnw_tab(nmbrad_snw)) then
2278 0 : Qs = Qs_tab(ns,nmbrad_snw)
2279 0 : ws = ws_tab(ns,nmbrad_snw)
2280 0 : gs = gs_tab(ns,nmbrad_snw)
2281 : else
2282 : ! linear interpolation in rsnw
2283 470060544 : do nr = 2, nmbrad_snw
2284 713236530 : if (rsnw_tab(nr-1) <= frsnw(ksnow) .and. &
2285 272554770 : frsnw(ksnow) < rsnw_tab(nr)) then
2286 8318238 : delr = (frsnw(ksnow) - rsnw_tab(nr-1)) / &
2287 14689392 : (rsnw_tab(nr) - rsnw_tab(nr-1))
2288 0 : Qs = Qs_tab(ns,nr-1)*(c1-delr) + &
2289 14689392 : Qs_tab(ns,nr )* delr
2290 0 : ws = ws_tab(ns,nr-1)*(c1-delr) + &
2291 14689392 : ws_tab(ns,nr )* delr
2292 0 : gs = gs_tab(ns,nr-1)*(c1-delr) + &
2293 14689392 : gs_tab(ns,nr )* delr
2294 : endif
2295 : enddo ! nr
2296 : endif
2297 8318238 : ks = Qs*((rhosnw(ksnow)/rhoi)*3._dbl_kind / &
2298 14689392 : (4._dbl_kind*frsnw(ksnow)*1.0e-6_dbl_kind))
2299 :
2300 14689392 : tau(k) = (ks + kabs_chl(ns,k))*dzk(k)
2301 14689392 : w0 (k) = ks/(ks + kabs_chl(ns,k)) * ws
2302 22034088 : g (k) = gs
2303 : enddo ! k
2304 :
2305 : ! aerosol in snow
2306 7344696 : if (tr_zaero .and. dEdd_algae) then
2307 0 : do k = 0,nslyr
2308 0 : g(k) = (g(k)*w0(k)*tau(k) + gzaer(ns,k)) / &
2309 0 : (w0(k)*tau(k) + wzaer(ns,k))
2310 0 : w0(k) = (w0(k)*tau(k) + wzaer(ns,k)) / &
2311 0 : (tau(k) + tzaer(ns,k))
2312 0 : tau(k) = tau(k) + tzaer(ns,k)
2313 : enddo
2314 7344696 : elseif (tr_aero) then
2315 0 : k = 0 ! snow SSL
2316 0 : taer = c0
2317 0 : waer = c0
2318 0 : gaer = c0
2319 :
2320 0 : do na = 1, 4*n_aero, 4
2321 0 : if (modal_aero) then
2322 0 : if (na == 1) then ! interstitial BC
2323 0 : taer = taer + aero_mp(na)*kaer_bc_3bd(ns,k_bcexs(k))
2324 0 : waer = waer + aero_mp(na)*kaer_bc_3bd(ns,k_bcexs(k)) &
2325 0 : *waer_bc_3bd(ns,k_bcexs(k))
2326 0 : gaer = gaer + aero_mp(na)*kaer_bc_3bd(ns,k_bcexs(k)) &
2327 : *waer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2328 0 : *gaer_bc_3bd(ns,k_bcexs(k))
2329 0 : elseif (na == 5) then ! within-ice BC
2330 0 : taer = taer + aero_mp(na)*kaer_bc_3bd(ns,k_bcins(k)) &
2331 0 : * bcenh_3bd(ns,k_bcins(k),k_bcini(k))
2332 0 : waer = waer + aero_mp(na)*kaer_bc_3bd(ns,k_bcins(k)) &
2333 0 : *waer_bc_3bd(ns,k_bcins(k))
2334 0 : gaer = gaer + aero_mp(na)*kaer_bc_3bd(ns,k_bcins(k)) &
2335 : *waer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2336 0 : *gaer_bc_3bd(ns,k_bcins(k))
2337 : else ! other species (dust)
2338 0 : taer = taer + aero_mp(na)*kaer_3bd(ns,(1+(na-1)/4))
2339 0 : waer = waer + aero_mp(na)*kaer_3bd(ns,(1+(na-1)/4)) &
2340 0 : *waer_3bd(ns,(1+(na-1)/4))
2341 0 : gaer = gaer + aero_mp(na)*kaer_3bd(ns,(1+(na-1)/4)) &
2342 : *waer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2343 0 : *gaer_3bd(ns,(1+(na-1)/4))
2344 : endif
2345 : else
2346 0 : taer = taer + aero_mp(na)*kaer_3bd(ns,(1+(na-1)/4))
2347 0 : waer = waer + aero_mp(na)*kaer_3bd(ns,(1+(na-1)/4)) &
2348 0 : *waer_3bd(ns,(1+(na-1)/4))
2349 0 : gaer = gaer + aero_mp(na)*kaer_3bd(ns,(1+(na-1)/4)) &
2350 : *waer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2351 0 : *gaer_3bd(ns,(1+(na-1)/4))
2352 : endif ! modal_aero
2353 : enddo ! na
2354 0 : g (k) = (g(k)*w0(k)*tau(k) + gaer) / &
2355 0 : (w0(k)*tau(k) + waer)
2356 0 : w0 (k) = (w0(k)*tau(k) + waer) / &
2357 0 : (tau(k) + taer)
2358 0 : tau(k) = tau(k) + taer
2359 :
2360 0 : do k = 1, nslyr
2361 0 : taer = c0
2362 0 : waer = c0
2363 0 : gaer = c0
2364 0 : do na = 1, 4*n_aero, 4
2365 0 : if (modal_aero) then
2366 0 : if (na==1) then ! interstitial BC
2367 0 : taer = taer + (aero_mp(na+1)*rnslyr) &
2368 0 : * kaer_bc_3bd(ns,k_bcexs(k))
2369 0 : waer = waer + (aero_mp(na+1)*rnslyr) &
2370 : * kaer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2371 0 : * waer_bc_3bd(ns,k_bcexs(k))
2372 0 : gaer = gaer + (aero_mp(na+1)*rnslyr) &
2373 : * kaer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2374 : * waer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2375 0 : * gaer_bc_3bd(ns,k_bcexs(k))
2376 0 : elseif (na==5) then ! within-ice BC
2377 0 : taer = taer + (aero_mp(na+1)*rnslyr) &
2378 : * kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2379 0 : * bcenh_3bd(ns,k_bcins(k),k_bcini(k))
2380 0 : waer = waer + (aero_mp(na+1)*rnslyr) &
2381 : * kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2382 0 : * waer_bc_3bd(ns,k_bcins(k))
2383 0 : gaer = gaer + (aero_mp(na+1)*rnslyr) &
2384 : * kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2385 : * waer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2386 0 : * gaer_bc_3bd(ns,k_bcins(k))
2387 : else ! other species (dust)
2388 0 : taer = taer + (aero_mp(na+1)*rnslyr) &
2389 0 : * kaer_3bd(ns,(1+(na-1)/4))
2390 0 : waer = waer + (aero_mp(na+1)*rnslyr) &
2391 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2392 0 : * waer_3bd(ns,(1+(na-1)/4))
2393 0 : gaer = gaer + (aero_mp(na+1)*rnslyr) &
2394 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2395 : * waer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2396 0 : * gaer_3bd(ns,(1+(na-1)/4))
2397 : endif ! na
2398 : else
2399 0 : taer = taer + (aero_mp(na+1)*rnslyr) &
2400 0 : * kaer_3bd(ns,(1+(na-1)/4))
2401 0 : waer = waer + (aero_mp(na+1)*rnslyr) &
2402 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2403 0 : * waer_3bd(ns,(1+(na-1)/4))
2404 0 : gaer = gaer + (aero_mp(na+1)*rnslyr) &
2405 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2406 : * waer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2407 0 : * gaer_3bd(ns,(1+(na-1)/4))
2408 : endif ! modal_aero
2409 : enddo ! na
2410 0 : g (k) = (g(k)*w0(k)*tau(k) + gaer) / &
2411 0 : (w0(k)*tau(k) + waer)
2412 0 : w0 (k) = (w0(k)*tau(k) + waer) / &
2413 0 : (tau(k) + taer)
2414 0 : tau(k) = tau(k) + taer
2415 : enddo ! k
2416 : endif ! tr_aero
2417 :
2418 : else ! srftyp == 2
2419 : ! pond water layers evenly spaced
2420 1042677 : dz = hp/(real(nslyr,kind=dbl_kind)+c1)
2421 3128031 : do k=0,nslyr
2422 2085354 : tau(k) = kw(ns)*dz
2423 2085354 : w0 (k) = ww(ns)
2424 3128031 : g (k) = gw(ns)
2425 : ! no aerosol in pond
2426 : enddo ! k
2427 : endif ! srftyp
2428 :
2429 : ! set optical properties of sea ice
2430 :
2431 : ! bare or snow-covered sea ice layers
2432 9354363 : if (srftyp <= 1) then
2433 : ! ssl
2434 8311686 : k = kii
2435 8311686 : tau(k) = (ki_ssl(ns) + kabs_chl(ns,k)) * dzk(k)
2436 8311686 : w0 (k) = ki_ssl(ns)/(ki_ssl(ns) + kabs_chl(ns,k)) * wi_ssl(ns)
2437 8311686 : g (k) = gi_ssl(ns)
2438 : ! dl
2439 8311686 : k = kii + 1
2440 : ! scale dz for dl relative to 4 even-layer-thickness 1.5m case
2441 8311686 : fs = p25*real(nilyr,kind=dbl_kind)
2442 8311686 : tau(k) = (ki_dl(ns) + kabs_chl(ns,k)) * dzk(k) * fs
2443 8311686 : w0 (k) = ki_dl(ns)/(ki_dl(ns) + kabs_chl(ns,k)) * wi_dl(ns)
2444 8311686 : g (k) = gi_dl(ns)
2445 : ! int above lowest layer
2446 8311686 : if (kii+2 <= klev-1) then
2447 49870116 : do k = kii+2, klev-1
2448 41558430 : tau(k) = (ki_int(ns) + kabs_chl(ns,k)) * dzk(k)
2449 41558430 : w0 (k) = ki_int(ns)/(ki_int(ns) + kabs_chl(ns,k)) * wi_int(ns)
2450 49870116 : g (k) = gi_int(ns)
2451 : enddo
2452 : endif
2453 : ! lowest layer
2454 8311686 : k = klev
2455 : ! add algae to lowest sea ice layer, visible only:
2456 8311686 : kabs = ki_int(ns)*(c1-wi_int(ns))
2457 8311686 : if (ns == 1) then
2458 : ! total layer absorption optical depth fixed at value
2459 : ! of kalg*0.50m, independent of actual layer thickness
2460 2770562 : kabs = kabs + kabs_chl(ns,k)
2461 : endif
2462 8311686 : sig = ki_int(ns) * wi_int(ns)
2463 8311686 : tau(k) = (kabs+sig) * dzk(k)
2464 8311686 : w0 (k) = sig/(sig+kabs)
2465 8311686 : g (k) = gi_int(ns)
2466 : ! aerosol in sea ice
2467 8311686 : if (tr_zaero .and. dEdd_algae) then
2468 0 : do k = kii, klev
2469 0 : g(k) = (g(k)*w0(k)*tau(k) + gzaer(ns,k)) / &
2470 0 : (w0(k)*tau(k) + wzaer(ns,k))
2471 0 : w0(k) = (w0(k)*tau(k) + wzaer(ns,k)) / &
2472 0 : (tau(k) + tzaer(ns,k))
2473 0 : tau(k) = tau(k) + tzaer(ns,k)
2474 : enddo
2475 8311686 : elseif (tr_aero) then
2476 0 : k = kii ! sea ice SSL
2477 0 : taer = c0
2478 0 : waer = c0
2479 0 : gaer = c0
2480 0 : do na=1,4*n_aero,4
2481 0 : if (modal_aero) then
2482 0 : if (na==1) then ! interstitial BC
2483 0 : taer = taer + aero_mp(na+2) &
2484 0 : * kaer_bc_3bd(ns,k_bcexs(k))
2485 0 : waer = waer + aero_mp(na+2) &
2486 : * kaer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2487 0 : * waer_bc_3bd(ns,k_bcexs(k))
2488 0 : gaer = gaer + aero_mp(na+2) &
2489 : * kaer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2490 : * waer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2491 0 : * gaer_bc_3bd(ns,k_bcexs(k))
2492 0 : elseif (na==5) then ! within-ice BC
2493 0 : taer = taer + aero_mp(na+2) &
2494 : * kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2495 0 : * bcenh_3bd(ns,k_bcins(k),k_bcini(k))
2496 0 : waer = waer + aero_mp(na+2) &
2497 : * kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2498 0 : * waer_bc_3bd(ns,k_bcins(k))
2499 0 : gaer = gaer + aero_mp(na+2) &
2500 : * kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2501 : * waer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2502 0 : * gaer_bc_3bd(ns,k_bcins(k))
2503 : else ! other species (dust)
2504 0 : taer = taer + aero_mp(na+2) &
2505 0 : * kaer_3bd(ns,(1+(na-1)/4))
2506 0 : waer = waer + aero_mp(na+2) &
2507 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2508 0 : * waer_3bd(ns,(1+(na-1)/4))
2509 0 : gaer = gaer + aero_mp(na+2) &
2510 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2511 : * waer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2512 0 : * gaer_3bd(ns,(1+(na-1)/4))
2513 : endif
2514 : else ! bulk
2515 0 : taer = taer + aero_mp(na+2) &
2516 0 : * kaer_3bd(ns,(1+(na-1)/4))
2517 0 : waer = waer + aero_mp(na+2) &
2518 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2519 0 : * waer_3bd(ns,(1+(na-1)/4))
2520 0 : gaer = gaer + aero_mp(na+2) &
2521 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2522 : * waer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2523 0 : * gaer_3bd(ns,(1+(na-1)/4))
2524 : endif ! modal_aero
2525 : enddo ! na
2526 0 : g (k) = (g(k)*w0(k)*tau(k) + gaer) / &
2527 0 : (w0(k)*tau(k) + waer)
2528 0 : w0 (k) = (w0(k)*tau(k) + waer) / &
2529 0 : (tau(k) + taer)
2530 0 : tau(k) = tau(k) + taer
2531 0 : do k = kii+1, klev
2532 0 : taer = c0
2533 0 : waer = c0
2534 0 : gaer = c0
2535 0 : do na = 1, 4*n_aero, 4
2536 0 : if (modal_aero) then
2537 0 : if (na==1) then ! interstitial BC
2538 0 : taer = taer + (aero_mp(na+3)*rnilyr) &
2539 0 : * kaer_bc_3bd(ns,k_bcexs(k))
2540 0 : waer = waer + (aero_mp(na+3)*rnilyr) &
2541 : * kaer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2542 0 : * waer_bc_3bd(ns,k_bcexs(k))
2543 0 : gaer = gaer + (aero_mp(na+3)*rnilyr) &
2544 : * kaer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2545 : * waer_bc_3bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
2546 0 : * gaer_bc_3bd(ns,k_bcexs(k))
2547 0 : elseif (na==5) then ! within-ice BC
2548 0 : taer = taer + (aero_mp(na+3)*rnilyr) &
2549 : * kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2550 0 : * bcenh_3bd(ns,k_bcins(k),k_bcini(k))
2551 0 : waer = waer + (aero_mp(na+3)*rnilyr) &
2552 : * kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2553 0 : * waer_bc_3bd(ns,k_bcins(k))
2554 0 : gaer = gaer + (aero_mp(na+3)*rnilyr) &
2555 : * kaer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2556 : * waer_bc_3bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
2557 0 : * gaer_bc_3bd(ns,k_bcins(k))
2558 : else ! other species (dust)
2559 0 : taer = taer + (aero_mp(na+3)*rnilyr) &
2560 0 : * kaer_3bd(ns,(1+(na-1)/4))
2561 0 : waer = waer + (aero_mp(na+3)*rnilyr) &
2562 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2563 0 : * waer_3bd(ns,(1+(na-1)/4))
2564 0 : gaer = gaer + (aero_mp(na+3)*rnilyr) &
2565 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2566 : * waer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2567 0 : * gaer_3bd(ns,(1+(na-1)/4))
2568 : endif
2569 : else ! bulk
2570 0 : taer = taer + (aero_mp(na+3)*rnilyr) &
2571 0 : * kaer_3bd(ns,(1+(na-1)/4))
2572 0 : waer = waer + (aero_mp(na+3)*rnilyr) &
2573 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2574 0 : * waer_3bd(ns,(1+(na-1)/4))
2575 0 : gaer = gaer + (aero_mp(na+3)*rnilyr) &
2576 : * kaer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2577 : * waer_3bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
2578 0 : * gaer_3bd(ns,(1+(na-1)/4))
2579 : endif ! modal_aero
2580 : enddo ! na
2581 0 : g (k) = (g(k)*w0(k)*tau(k) + gaer) / &
2582 0 : (w0(k)*tau(k) + waer)
2583 0 : w0 (k) = (w0(k)*tau(k) + waer) / &
2584 0 : (tau(k) + taer)
2585 0 : tau(k) = tau(k) + taer
2586 : enddo ! k
2587 : endif ! tr_aero
2588 :
2589 : else ! srftyp == 2
2590 : ! sea ice layers under ponds
2591 1042677 : k = kii
2592 1042677 : tau(k) = ki_p_ssl(ns)*dzk(k)
2593 1042677 : w0 (k) = wi_p_ssl(ns)
2594 1042677 : g (k) = gi_p_ssl(ns)
2595 1042677 : k = kii + 1
2596 1042677 : tau(k) = ki_p_int(ns)*dzk(k)
2597 1042677 : w0 (k) = wi_p_int(ns)
2598 1042677 : g (k) = gi_p_int(ns)
2599 1042677 : if (kii+2 <= klev) then
2600 7298739 : do k = kii+2, klev
2601 6256062 : tau(k) = ki_p_int(ns)*dzk(k)
2602 6256062 : w0 (k) = wi_p_int(ns)
2603 7298739 : g (k) = gi_p_int(ns)
2604 : enddo ! k
2605 : endif
2606 : ! adjust pond iops if pond depth within specified range
2607 1042677 : if( hpmin <= hp .and. hp <= hp0 ) then
2608 1042677 : k = kii
2609 1042677 : sig_i = ki_ssl (ns) * wi_ssl (ns)
2610 1042677 : sig_p = ki_p_ssl(ns) * wi_p_ssl(ns)
2611 1042677 : sig = sig_i + (sig_p-sig_i) * (hp/hp0)
2612 1042677 : kext = sig + ki_p_ssl(ns) * (c1-wi_p_ssl(ns))
2613 1042677 : tau(k) = kext*dzk(k)
2614 1042677 : w0 (k) = sig/kext
2615 1042677 : g (k) = gi_p_int(ns)
2616 1042677 : k = kii + 1
2617 : ! scale dz for dl relative to 4 even-layer-thickness 1.5m case
2618 1042677 : fs = p25*real(nilyr,kind=dbl_kind)
2619 1042677 : sig_i = ki_dl (ns) * wi_dl (ns) * fs
2620 1042677 : sig_p = ki_p_int(ns) * wi_p_int(ns)
2621 1042677 : sig = sig_i + (sig_p-sig_i) * (hp/hp0)
2622 1042677 : kext = sig + ki_p_int(ns) * (c1-wi_p_int(ns))
2623 1042677 : tau(k) = kext*dzk(k)
2624 1042677 : w0 (k) = sig/kext
2625 1042677 : g (k) = gi_p_int(ns)
2626 1042677 : if (kii+2 <= klev) then
2627 7298739 : do k = kii+2, klev
2628 6256062 : sig_i = ki_int (ns) * wi_int (ns)
2629 6256062 : sig_p = ki_p_int(ns) * wi_p_int(ns)
2630 6256062 : sig = sig_i + (sig_p-sig_i) * (hp/hp0)
2631 6256062 : kext = sig + ki_p_int(ns) * (c1-wi_p_int(ns))
2632 6256062 : tau(k) = kext*dzk(k)
2633 6256062 : w0 (k) = sig/kext
2634 7298739 : g (k) = gi_p_int(ns)
2635 : enddo ! k
2636 : endif
2637 : endif ! small pond depth transition to bare sea ice
2638 : endif ! srftyp
2639 :
2640 : ! set reflectivities for ocean underlying sea ice
2641 9354363 : rns = real(ns-1, kind=dbl_kind)
2642 9354363 : albodr = cp01 * (c1 - min(rns, c1))
2643 9354363 : albodf = cp01 * (c1 - min(rns, c1))
2644 :
2645 : ! layer input properties now completely specified: tau, w0, g,
2646 : ! albodr, albodf; now compute the Delta-Eddington solution
2647 : ! reflectivities and transmissivities for each layer; then,
2648 : ! combine the layers going downwards accounting for multiple
2649 : ! scattering between layers, and finally start from the
2650 : ! underlying ocean and combine successive layers upwards to
2651 : ! the surface; see comments in solution_dEdd for more details.
2652 :
2653 : call solution_dEdd ( &
2654 : coszen, srftyp, klev, klevp, & ! LCOV_EXCL_LINE
2655 : tau, w0, g, albodr, albodf, & ! LCOV_EXCL_LINE
2656 : trndir, trntdr, trndif, rupdir, rupdif, & ! LCOV_EXCL_LINE
2657 9354363 : rdndif)
2658 9354363 : if (icepack_warnings_aborted(subname)) return
2659 :
2660 : ! the interface reflectivities and transmissivities required
2661 : ! to evaluate interface fluxes are returned from solution_dEdd;
2662 : ! now compute up and down fluxes for each interface, using the
2663 : ! combined layer properties at each interface:
2664 : !
2665 : ! layers interface
2666 : !
2667 : ! --------------------- k
2668 : ! k
2669 : ! ---------------------
2670 :
2671 112252356 : do k = 0, klevp
2672 : ! interface scattering
2673 102897993 : refk = c1/(c1 - rdndif(k)*rupdif(k))
2674 : ! dir tran ref from below times interface scattering, plus diff
2675 : ! tran and ref from below times interface scattering
2676 : ! fdirup(k) = (trndir(k)*rupdir(k) + &
2677 : ! (trntdr(k)-trndir(k)) & ! LCOV_EXCL_LINE
2678 : ! *rupdif(k))*refk
2679 : ! dir tran plus total diff trans times interface scattering plus
2680 : ! dir tran with up dir ref and down dif ref times interface scattering
2681 : ! fdirdn(k) = trndir(k) + (trntdr(k) &
2682 : ! - trndir(k) + trndir(k) & ! LCOV_EXCL_LINE
2683 : ! *rupdir(k)*rdndif(k))*refk
2684 : ! diffuse tran ref from below times interface scattering
2685 : ! fdifup(k) = trndif(k)*rupdif(k)*refk
2686 : ! diffuse tran times interface scattering
2687 : ! fdifdn(k) = trndif(k)*refk
2688 :
2689 : ! dfdir = fdirdn - fdirup
2690 60176094 : dfdir(k) = trndir(k) &
2691 : + (trntdr(k)-trndir(k)) * (c1 - rupdif(k)) * refk & ! LCOV_EXCL_LINE
2692 102897993 : - trndir(k)*rupdir(k) * (c1 - rdndif(k)) * refk
2693 102897993 : if (dfdir(k) < puny) dfdir(k) = c0 !echmod necessary?
2694 : ! dfdif = fdifdn - fdifup
2695 102897993 : dfdif(k) = trndif(k) * (c1 - rupdif(k)) * refk
2696 112252356 : if (dfdif(k) < puny) dfdif(k) = c0 !echmod necessary?
2697 : enddo ! k
2698 :
2699 : ! calculate final surface albedos and fluxes-
2700 : ! all absorbed flux above ksrf is included in surface absorption
2701 12472484 : if (ns == 1) then ! visible
2702 3118121 : swdr = swvdr
2703 3118121 : swdf = swvdf
2704 3118121 : avdr = rupdir(0)
2705 3118121 : avdf = rupdif(0)
2706 3118121 : tmp_0 = dfdir(0 )*swdr + dfdif(0 )*swdf
2707 3118121 : tmp_ks = dfdir(ksrf )*swdr + dfdif(ksrf )*swdf
2708 3118121 : tmp_kl = dfdir(klevp)*swdr + dfdif(klevp)*swdf
2709 :
2710 : ! for layer biology: save visible only
2711 28063089 : do k = nslyr+2, klevp ! Start at DL layer of ice after SSL scattering
2712 28063089 : fthrul(k-nslyr-1) = dfdir(k)*swdr + dfdif(k)*swdf
2713 : enddo
2714 :
2715 3118121 : fsfc = fsfc + tmp_0 - tmp_ks
2716 3118121 : fint = fint + tmp_ks - tmp_kl
2717 3118121 : fthru = fthru + tmp_kl
2718 3118121 : fthruvdr = fthruvdr + dfdir(klevp)*swdr
2719 3118121 : fthruvdf = fthruvdf + dfdif(klevp)*swdf
2720 :
2721 : ! if snow covered ice, set snow internal absorption; else, Sabs=0
2722 3118121 : if (srftyp == 1) then
2723 2448232 : ki = 0
2724 4896464 : do k = 1, nslyr
2725 : ! skip snow SSL, since SSL absorption included in the surface
2726 : ! absorption fsfc above
2727 2448232 : km = k
2728 2448232 : kp = km + 1
2729 2448232 : ki = ki + 1
2730 1386373 : Sabs(ki) = Sabs(ki) &
2731 : + dfdir(km)*swdr + dfdif(km)*swdf & ! LCOV_EXCL_LINE
2732 4896464 : - (dfdir(kp)*swdr + dfdif(kp)*swdf)
2733 : enddo ! k
2734 : endif
2735 :
2736 : ! complex indexing to insure proper absorptions for sea ice
2737 3118121 : ki = 0
2738 24944968 : do k = nslyr+2, nslyr+1+nilyr
2739 : ! for bare ice, DL absorption for sea ice layer 1
2740 21826847 : km = k
2741 21826847 : kp = km + 1
2742 : ! modify for top sea ice layer for snow over sea ice
2743 21826847 : if (srftyp == 1) then
2744 : ! must add SSL and DL absorption for sea ice layer 1
2745 17137624 : if (k == nslyr+2) then
2746 2448232 : km = k - 1
2747 2448232 : kp = km + 2
2748 : endif
2749 : endif
2750 21826847 : ki = ki + 1
2751 12764626 : Iabs(ki) = Iabs(ki) &
2752 : + dfdir(km)*swdr + dfdif(km)*swdf & ! LCOV_EXCL_LINE
2753 24944968 : - (dfdir(kp)*swdr + dfdif(kp)*swdf)
2754 : enddo ! k
2755 :
2756 : else ! ns > 1, near IR
2757 :
2758 6236242 : swdr = swidr
2759 6236242 : swdf = swidf
2760 :
2761 : ! let fr1 = alb_1*swd*wght1 and fr2 = alb_2*swd*wght2 be the ns=2,3
2762 : ! reflected fluxes respectively, where alb_1, alb_2 are the band
2763 : ! albedos, swd = nir incident shortwave flux, and wght1, wght2 are
2764 : ! the 2,3 band weights. thus, the total reflected flux is:
2765 : ! fr = fr1 + fr2 = alb_1*swd*wght1 + alb_2*swd*wght2 hence, the
2766 : ! 2,3 nir band albedo is alb = fr/swd = alb_1*wght1 + alb_2*wght2
2767 :
2768 6236242 : aidr = aidr + rupdir(0)*wghtns(ns)
2769 6236242 : aidf = aidf + rupdif(0)*wghtns(ns)
2770 :
2771 6236242 : tmp_0 = dfdir(0 )*swdr + dfdif(0 )*swdf
2772 6236242 : tmp_ks = dfdir(ksrf )*swdr + dfdif(ksrf )*swdf
2773 6236242 : tmp_kl = dfdir(klevp)*swdr + dfdif(klevp)*swdf
2774 :
2775 6236242 : tmp_0 = tmp_0 * wghtns(ns)
2776 6236242 : tmp_ks = tmp_ks * wghtns(ns)
2777 6236242 : tmp_kl = tmp_kl * wghtns(ns)
2778 :
2779 6236242 : fsfc = fsfc + tmp_0 - tmp_ks
2780 6236242 : fint = fint + tmp_ks - tmp_kl
2781 6236242 : fthru = fthru + tmp_kl
2782 6236242 : fthruidr = fthruidr + dfdir(klevp)*swdr*wghtns(ns)
2783 6236242 : fthruidf = fthruidf + dfdif(klevp)*swdf*wghtns(ns)
2784 :
2785 : ! if snow covered ice, set snow internal absorption; else, Sabs=0
2786 6236242 : if (srftyp == 1) then
2787 4896464 : ki = 0
2788 9792928 : do k = 1, nslyr
2789 : ! skip snow SSL, since SSL absorption included in the surface
2790 : ! absorption fsfc above
2791 4896464 : km = k
2792 4896464 : kp = km + 1
2793 4896464 : ki = ki + 1
2794 2772746 : Sabs(ki) = Sabs(ki) &
2795 : + (dfdir(km)*swdr + dfdif(km)*swdf & ! LCOV_EXCL_LINE
2796 : - (dfdir(kp)*swdr + dfdif(kp)*swdf)) & ! LCOV_EXCL_LINE
2797 9792928 : * wghtns(ns)
2798 : enddo ! k
2799 : endif
2800 :
2801 : ! complex indexing to insure proper absorptions for sea ice
2802 6236242 : ki = 0
2803 49889936 : do k = nslyr+2, nslyr+1+nilyr
2804 : ! for bare ice, DL absorption for sea ice layer 1
2805 43653694 : km = k
2806 43653694 : kp = km + 1
2807 : ! modify for top sea ice layer for snow over sea ice
2808 43653694 : if (srftyp == 1) then
2809 : ! must add SSL and DL absorption for sea ice layer 1
2810 34275248 : if (k == nslyr+2) then
2811 4896464 : km = k - 1
2812 4896464 : kp = km + 2
2813 : endif
2814 : endif
2815 43653694 : ki = ki + 1
2816 25529252 : Iabs(ki) = Iabs(ki) &
2817 : + (dfdir(km)*swdr + dfdif(km)*swdf & ! LCOV_EXCL_LINE
2818 : - (dfdir(kp)*swdr + dfdif(kp)*swdf)) & ! LCOV_EXCL_LINE
2819 49889936 : * wghtns(ns)
2820 : enddo ! k
2821 : endif ! ns
2822 : enddo ! ns: end spectral loop
2823 :
2824 3118121 : alvdr = avdr
2825 3118121 : alvdf = avdf
2826 3118121 : alidr = aidr
2827 3118121 : alidf = aidf
2828 :
2829 : ! accumulate fluxes over bare sea ice
2830 3118121 : fswsfc = fswsfc + fsfc *fi
2831 3118121 : fswint = fswint + fint *fi
2832 3118121 : fswthru = fswthru + fthru*fi
2833 3118121 : fswthru_vdr = fswthru_vdr + fthruvdr*fi
2834 3118121 : fswthru_vdf = fswthru_vdf + fthruvdf*fi
2835 3118121 : fswthru_idr = fswthru_idr + fthruidr*fi
2836 3118121 : fswthru_idf = fswthru_idf + fthruidf*fi
2837 :
2838 6236242 : do k = 1, nslyr
2839 6236242 : Sswabs(k) = Sswabs(k) + Sabs(k)*fi
2840 : enddo
2841 :
2842 24944968 : do k = 1, nilyr
2843 21826847 : Iswabs(k) = Iswabs(k) + Iabs(k)*fi
2844 : ! bgc layer
2845 24944968 : fswpenl(k) = fswpenl(k) + fthrul(k)* fi
2846 : enddo
2847 3118121 : fswpenl(nilyr+1) = fswpenl(nilyr+1) + fthrul(nilyr+1)*fi
2848 :
2849 : end subroutine compute_dEdd_3bd
2850 :
2851 : !=======================================================================
2852 : !
2853 : ! Given input vertical profiles of optical properties, evaluate the
2854 : ! monochromatic Delta-Eddington solution.
2855 : !
2856 : ! author: Bruce P. Briegleb, NCAR
2857 : ! 2013: E Hunke merged with NCAR version
2858 9354363 : subroutine solution_dEdd ( &
2859 : coszen, srftyp, klev, klevp, & ! LCOV_EXCL_LINE
2860 : tau, w0, g, albodr, albodf, & ! LCOV_EXCL_LINE
2861 : trndir, trntdr, trndif, rupdir, rupdif, & ! LCOV_EXCL_LINE
2862 9354363 : rdndif)
2863 :
2864 : real (kind=dbl_kind), intent(in) :: &
2865 : coszen ! cosine solar zenith angle
2866 :
2867 : integer (kind=int_kind), intent(in) :: &
2868 : srftyp , & ! surface type over ice: (0=air, 1=snow, 2=pond) ! LCOV_EXCL_LINE
2869 : klev , & ! number of radiation layers - 1 ! LCOV_EXCL_LINE
2870 : klevp ! number of radiation interfaces - 1
2871 : ! (0 layer is included also)
2872 :
2873 : real (kind=dbl_kind), dimension(0:klev), intent(in) :: &
2874 : tau , & ! layer extinction optical depth ! LCOV_EXCL_LINE
2875 : w0 , & ! layer single scattering albedo ! LCOV_EXCL_LINE
2876 : g ! layer asymmetry parameter
2877 :
2878 : real (kind=dbl_kind), intent(in) :: &
2879 : albodr , & ! ocean albedo to direct rad ! LCOV_EXCL_LINE
2880 : albodf ! ocean albedo to diffuse rad
2881 :
2882 : ! following arrays are defined at model interfaces; 0 is the top of the
2883 : ! layer above the sea ice; klevp is the sea ice/ocean interface.
2884 : real (kind=dbl_kind), dimension (0:klevp), intent(out) :: &
2885 : trndir , & ! solar beam down transmission from top ! LCOV_EXCL_LINE
2886 : trntdr , & ! total transmission to direct beam for layers above ! LCOV_EXCL_LINE
2887 : trndif , & ! diffuse transmission to diffuse beam for layers above ! LCOV_EXCL_LINE
2888 : rupdir , & ! reflectivity to direct radiation for layers below ! LCOV_EXCL_LINE
2889 : rupdif , & ! reflectivity to diffuse radiation for layers below ! LCOV_EXCL_LINE
2890 : rdndif ! reflectivity to diffuse radiation for layers above
2891 :
2892 : !-----------------------------------------------------------------------
2893 : !
2894 : ! Delta-Eddington solution for snow/air/pond over sea ice
2895 : !
2896 : ! Generic solution for a snow/air/pond input column of klev+1 layers,
2897 : ! with srftyp determining at what interface fresnel refraction occurs.
2898 : !
2899 : ! Computes layer reflectivities and transmissivities, from the top down
2900 : ! to the lowest interface using the Delta-Eddington solutions for each
2901 : ! layer; combines layers from top down to lowest interface, and from the
2902 : ! lowest interface (underlying ocean) up to the top of the column.
2903 : !
2904 : ! Note that layer diffuse reflectivity and transmissivity are computed
2905 : ! by integrating the direct over several gaussian angles. This is
2906 : ! because the diffuse reflectivity expression sometimes is negative,
2907 : ! but the direct reflectivity is always well-behaved. We assume isotropic
2908 : ! radiation in the upward and downward hemispheres for this integration.
2909 : !
2910 : ! Assumes monochromatic (spectrally uniform) properties across a band
2911 : ! for the input optical parameters.
2912 : !
2913 : ! If total transmission of the direct beam to the interface above a particular
2914 : ! layer is less than trmin, then no further Delta-Eddington solutions are
2915 : ! evaluated for layers below.
2916 : !
2917 : ! The following describes how refraction is handled in the calculation.
2918 : !
2919 : ! First, we assume that radiation is refracted when entering either
2920 : ! sea ice at the base of the surface scattering layer, or water (i.e. melt
2921 : ! pond); we assume that radiation does not refract when entering snow, nor
2922 : ! upon entering sea ice from a melt pond, nor upon entering the underlying
2923 : ! ocean from sea ice.
2924 : !
2925 : ! To handle refraction, we define a "fresnel" layer, which physically
2926 : ! is of neglible thickness and is non-absorbing, which can be combined to
2927 : ! any sea ice layer or top of melt pond. The fresnel layer accounts for
2928 : ! refraction of direct beam and associated reflection and transmission for
2929 : ! solar radiation. A fresnel layer is combined with the top of a melt pond
2930 : ! or to the surface scattering layer of sea ice if no melt pond lies over it.
2931 : !
2932 : ! Some caution must be exercised for the fresnel layer, because any layer
2933 : ! to which it is combined is no longer a homogeneous layer, as are all other
2934 : ! individual layers. For all other layers for example, the direct and diffuse
2935 : ! reflectivities/transmissivities (R/T) are the same for radiation above or
2936 : ! below the layer. This is the meaning of homogeneous! But for the fresnel
2937 : ! layer this is not so. Thus, the R/T for this layer must be distinguished
2938 : ! for radiation above from that from radiation below. For generality, we
2939 : ! treat all layers to be combined as inhomogeneous.
2940 : !
2941 : !-----------------------------------------------------------------------
2942 :
2943 : ! local variables
2944 :
2945 : integer (kind=int_kind) :: &
2946 : kfrsnl ! radiation interface index for fresnel layer
2947 :
2948 : ! following variables are defined for each layer; 0 refers to the top
2949 : ! layer. In general we must distinguish directions above and below in
2950 : ! the diffuse reflectivity and transmissivity, as layers are not assumed
2951 : ! to be homogeneous (apart from the single layer Delta-Edd solutions);
2952 : ! the direct is always from above.
2953 : real (kind=dbl_kind), dimension (0:klev) :: &
2954 : rdir , & ! layer reflectivity to direct radiation ! LCOV_EXCL_LINE
2955 : rdif_a , & ! layer reflectivity to diffuse radiation from above ! LCOV_EXCL_LINE
2956 : rdif_b , & ! layer reflectivity to diffuse radiation from below ! LCOV_EXCL_LINE
2957 : tdir , & ! layer transmission to direct radiation (solar beam + diffuse) ! LCOV_EXCL_LINE
2958 : tdif_a , & ! layer transmission to diffuse radiation from above ! LCOV_EXCL_LINE
2959 : tdif_b , & ! layer transmission to diffuse radiation from below ! LCOV_EXCL_LINE
2960 67943712 : trnlay ! solar beam transm for layer (direct beam only)
2961 :
2962 : integer (kind=int_kind) :: &
2963 : k ! level index
2964 :
2965 : real (kind=dbl_kind), parameter :: &
2966 : trmin = 0.001_dbl_kind ! minimum total transmission allowed
2967 : ! total transmission is that due to the direct beam; i.e. it includes
2968 : ! both the directly transmitted solar beam and the diffuse downwards
2969 : ! transmitted radiation resulting from scattering out of the direct beam
2970 : real (kind=dbl_kind) :: &
2971 : tautot , & ! layer optical depth ! LCOV_EXCL_LINE
2972 : wtot , & ! layer single scattering albedo ! LCOV_EXCL_LINE
2973 : gtot , & ! layer asymmetry parameter ! LCOV_EXCL_LINE
2974 : ftot , & ! layer forward scattering fraction ! LCOV_EXCL_LINE
2975 : ts , & ! layer scaled extinction optical depth ! LCOV_EXCL_LINE
2976 : ws , & ! layer scaled single scattering albedo ! LCOV_EXCL_LINE
2977 : gs , & ! layer scaled asymmetry parameter ! LCOV_EXCL_LINE
2978 : rintfc , & ! reflection (multiple) at an interface ! LCOV_EXCL_LINE
2979 : refkp1 , & ! interface multiple scattering for k+1 ! LCOV_EXCL_LINE
2980 : refkm1 , & ! interface multiple scattering for k-1 ! LCOV_EXCL_LINE
2981 : tdrrdir , & ! direct tran times layer direct ref ! LCOV_EXCL_LINE
2982 5470554 : tdndif ! total down diffuse = tot tran - direct tran
2983 :
2984 : ! perpendicular and parallel relative to plane of incidence and scattering
2985 : real (kind=dbl_kind) :: &
2986 : R1 , & ! perpendicular polarization reflection amplitude ! LCOV_EXCL_LINE
2987 : R2 , & ! parallel polarization reflection amplitude ! LCOV_EXCL_LINE
2988 : T1 , & ! perpendicular polarization transmission amplitude ! LCOV_EXCL_LINE
2989 : T2 , & ! parallel polarization transmission amplitude ! LCOV_EXCL_LINE
2990 : Rf_dir_a , & ! fresnel reflection to direct radiation ! LCOV_EXCL_LINE
2991 : Tf_dir_a , & ! fresnel transmission to direct radiation ! LCOV_EXCL_LINE
2992 : Rf_dif_a , & ! fresnel reflection to diff radiation from above ! LCOV_EXCL_LINE
2993 : Rf_dif_b , & ! fresnel reflection to diff radiation from below ! LCOV_EXCL_LINE
2994 : Tf_dif_a , & ! fresnel transmission to diff radiation from above ! LCOV_EXCL_LINE
2995 5470554 : Tf_dif_b ! fresnel transmission to diff radiation from below
2996 :
2997 : ! refractive index for sea ice, water; pre-computed, band-independent,
2998 : ! diffuse fresnel reflectivities
2999 : real (kind=dbl_kind), parameter :: &
3000 : refindx = 1.310_dbl_kind , & ! refractive index of sea ice (water also) ! LCOV_EXCL_LINE
3001 : cp063 = 0.063_dbl_kind , & ! diffuse fresnel reflectivity from above ! LCOV_EXCL_LINE
3002 : cp455 = 0.455_dbl_kind ! diffuse fresnel reflectivity from below
3003 :
3004 : real (kind=dbl_kind) :: &
3005 : mu0 , & ! cosine solar zenith angle incident ! LCOV_EXCL_LINE
3006 5470554 : mu0nij ! cosine solar zenith angle in medium below fresnel level
3007 :
3008 : real (kind=dbl_kind) :: &
3009 5470554 : mu0n ! cosine solar zenith angle in medium
3010 :
3011 : real (kind=dbl_kind) :: &
3012 : alp , & ! temporary for alpha ! LCOV_EXCL_LINE
3013 : gam , & ! temporary for agamm ! LCOV_EXCL_LINE
3014 : lm , & ! temporary for el ! LCOV_EXCL_LINE
3015 : mu , & ! temporary for gauspt ! LCOV_EXCL_LINE
3016 : ne , & ! temporary for n ! LCOV_EXCL_LINE
3017 : ue , & ! temporary for u ! LCOV_EXCL_LINE
3018 : extins , & ! extinction ! LCOV_EXCL_LINE
3019 : amg , & ! alp - gam ! LCOV_EXCL_LINE
3020 5470554 : apg ! alp + gam
3021 :
3022 : integer (kind=int_kind), parameter :: &
3023 : ngmax = 8 ! number of gaussian angles in hemisphere
3024 :
3025 : real (kind=dbl_kind), dimension (ngmax), parameter :: &
3026 : gauspt & ! gaussian angles (radians) ! LCOV_EXCL_LINE
3027 : = (/ .9894009_dbl_kind, .9445750_dbl_kind, & ! LCOV_EXCL_LINE
3028 : .8656312_dbl_kind, .7554044_dbl_kind, & ! LCOV_EXCL_LINE
3029 : .6178762_dbl_kind, .4580168_dbl_kind, & ! LCOV_EXCL_LINE
3030 : .2816036_dbl_kind, .0950125_dbl_kind/), & ! LCOV_EXCL_LINE
3031 : gauswt & ! gaussian weights ! LCOV_EXCL_LINE
3032 : = (/ .0271525_dbl_kind, .0622535_dbl_kind, & ! LCOV_EXCL_LINE
3033 : .0951585_dbl_kind, .1246290_dbl_kind, & ! LCOV_EXCL_LINE
3034 : .1495960_dbl_kind, .1691565_dbl_kind, & ! LCOV_EXCL_LINE
3035 : .1826034_dbl_kind, .1894506_dbl_kind/)
3036 :
3037 : integer (kind=int_kind) :: &
3038 : ng ! gaussian integration index
3039 :
3040 : real (kind=dbl_kind) :: &
3041 : gwt , & ! gaussian weight ! LCOV_EXCL_LINE
3042 : swt , & ! sum of weights ! LCOV_EXCL_LINE
3043 : trn , & ! layer transmission ! LCOV_EXCL_LINE
3044 : rdr , & ! rdir for gaussian integration ! LCOV_EXCL_LINE
3045 : tdr , & ! tdir for gaussian integration ! LCOV_EXCL_LINE
3046 : smr , & ! accumulator for rdif gaussian integration ! LCOV_EXCL_LINE
3047 5470554 : smt ! accumulator for tdif gaussian integration
3048 :
3049 : real (kind=dbl_kind) :: &
3050 5470554 : exp_min ! minimum exponential value
3051 :
3052 : character(len=*),parameter :: subname='(solution_dEdd)'
3053 :
3054 : !-----------------------------------------------------------------------
3055 :
3056 112252356 : do k = 0, klevp
3057 102897993 : trndir(k) = c0
3058 102897993 : trntdr(k) = c0
3059 102897993 : trndif(k) = c0
3060 102897993 : rupdir(k) = c0
3061 102897993 : rupdif(k) = c0
3062 112252356 : rdndif(k) = c0
3063 : enddo
3064 :
3065 : ! initialize top interface of top layer
3066 9354363 : trndir(0) = c1
3067 9354363 : trntdr(0) = c1
3068 9354363 : trndif(0) = c1
3069 9354363 : rdndif(0) = c0
3070 :
3071 : ! mu0 is cosine solar zenith angle above the fresnel level; make
3072 : ! sure mu0 is large enough for stable and meaningful radiation
3073 : ! solution: .01 is like sun just touching horizon with its lower edge
3074 9354363 : mu0 = max(coszen,p01)
3075 :
3076 : ! mu0n is cosine solar zenith angle used to compute the layer
3077 : ! Delta-Eddington solution; it is initially computed to be the
3078 : ! value below the fresnel level, i.e. the cosine solar zenith
3079 : ! angle below the fresnel level for the refracted solar beam:
3080 9354363 : mu0nij = sqrt(c1-((c1-mu0**2)/(refindx*refindx)))
3081 :
3082 : ! compute level of fresnel refraction
3083 : ! if ponded sea ice, fresnel level is the top of the pond.
3084 9354363 : kfrsnl = 0
3085 : ! if snow over sea ice or bare sea ice, fresnel level is
3086 : ! at base of sea ice SSL (and top of the sea ice DL); the
3087 : ! snow SSL counts for one, then the number of snow layers,
3088 : ! then the sea ice SSL which also counts for one:
3089 9354363 : if( srftyp < 2 ) kfrsnl = nslyr + 2
3090 :
3091 : ! proceed down one layer at a time; if the total transmission to
3092 : ! the interface just above a given layer is less than trmin, then no
3093 : ! Delta-Eddington computation for that layer is done.
3094 :
3095 : ! begin main level loop
3096 102897993 : do k = 0, klev
3097 :
3098 : ! initialize all layer apparent optical properties to 0
3099 93543630 : rdir (k) = c0
3100 93543630 : rdif_a(k) = c0
3101 93543630 : rdif_b(k) = c0
3102 93543630 : tdir (k) = c0
3103 93543630 : tdif_a(k) = c0
3104 93543630 : tdif_b(k) = c0
3105 93543630 : trnlay(k) = c0
3106 :
3107 : ! compute next layer Delta-eddington solution only if total transmission
3108 : ! of radiation to the interface just above the layer exceeds trmin.
3109 :
3110 93543630 : if (trntdr(k) > trmin ) then
3111 :
3112 : ! calculation over layers with penetrating radiation
3113 :
3114 45515488 : tautot = tau(k)
3115 45515488 : wtot = w0(k)
3116 45515488 : gtot = g(k)
3117 45515488 : ftot = gtot*gtot
3118 :
3119 45515488 : ts = taus(wtot,ftot,tautot)
3120 45515488 : ws = omgs(wtot,ftot)
3121 45515488 : gs = asys(gtot,ftot)
3122 45515488 : lm = el(ws,gs)
3123 45515488 : ue = u(ws,gs,lm)
3124 :
3125 45515488 : mu0n = mu0nij
3126 : ! if level k is above fresnel level and the cell is non-pond, use the
3127 : ! non-refracted beam instead
3128 45515488 : if( srftyp < 2 .and. k < kfrsnl ) mu0n = mu0
3129 :
3130 45515488 : exp_min = min(exp_argmax,lm*ts)
3131 45515488 : extins = exp(-exp_min)
3132 45515488 : ne = n(ue,extins)
3133 :
3134 : ! first calculation of rdif, tdif using Delta-Eddington formulas
3135 : ! rdif_a(k) = (ue+c1)*(ue-c1)*(c1/extins - extins)/ne
3136 45515488 : rdif_a(k) = (ue**2-c1)*(c1/extins - extins)/ne
3137 45515488 : tdif_a(k) = c4*ue/ne
3138 :
3139 : ! evaluate rdir,tdir for direct beam
3140 45515488 : exp_min = min(exp_argmax,ts/mu0n)
3141 45515488 : trnlay(k) = exp(-exp_min)
3142 45515488 : alp = alpha(ws,mu0n,gs,lm)
3143 45515488 : gam = agamm(ws,mu0n,gs,lm)
3144 45515488 : apg = alp + gam
3145 45515488 : amg = alp - gam
3146 45515488 : rdir(k) = apg*rdif_a(k) + amg*(tdif_a(k)*trnlay(k) - c1)
3147 45515488 : tdir(k) = apg*tdif_a(k) + (amg* rdif_a(k)-apg+c1)*trnlay(k)
3148 :
3149 : ! recalculate rdif,tdif using direct angular integration over rdir,tdir,
3150 : ! since Delta-Eddington rdif formula is not well-behaved (it is usually
3151 : ! biased low and can even be negative); use ngmax angles and gaussian
3152 : ! integration for most accuracy:
3153 45515488 : R1 = rdif_a(k) ! use R1 as temporary
3154 45515488 : T1 = tdif_a(k) ! use T1 as temporary
3155 45515488 : swt = c0
3156 45515488 : smr = c0
3157 45515488 : smt = c0
3158 409639392 : do ng=1,ngmax
3159 364123904 : mu = gauspt(ng)
3160 364123904 : gwt = gauswt(ng)
3161 364123904 : swt = swt + mu*gwt
3162 364123904 : exp_min = min(exp_argmax,ts/mu)
3163 364123904 : trn = exp(-exp_min)
3164 364123904 : alp = alpha(ws,mu,gs,lm)
3165 364123904 : gam = agamm(ws,mu,gs,lm)
3166 364123904 : apg = alp + gam
3167 364123904 : amg = alp - gam
3168 364123904 : rdr = apg*R1 + amg*T1*trn - amg
3169 364123904 : tdr = apg*T1 + amg*R1*trn - apg*trn + trn
3170 364123904 : smr = smr + mu*rdr*gwt
3171 409639392 : smt = smt + mu*tdr*gwt
3172 : enddo ! ng
3173 45515488 : rdif_a(k) = smr/swt
3174 45515488 : tdif_a(k) = smt/swt
3175 :
3176 : ! homogeneous layer
3177 45515488 : rdif_b(k) = rdif_a(k)
3178 45515488 : tdif_b(k) = tdif_a(k)
3179 :
3180 : ! add fresnel layer to top of desired layer if either
3181 : ! air or snow overlies ice; we ignore refraction in ice
3182 : ! if a melt pond overlies it:
3183 :
3184 45515488 : if( k == kfrsnl ) then
3185 : ! compute fresnel reflection and transmission amplitudes
3186 : ! for two polarizations: 1=perpendicular and 2=parallel to
3187 : ! the plane containing incident, reflected and refracted rays.
3188 : R1 = (mu0 - refindx*mu0n) / &
3189 4760649 : (mu0 + refindx*mu0n)
3190 : R2 = (refindx*mu0 - mu0n) / &
3191 4760649 : (refindx*mu0 + mu0n)
3192 : T1 = c2*mu0 / &
3193 4760649 : (mu0 + refindx*mu0n)
3194 : T2 = c2*mu0 / &
3195 4760649 : (refindx*mu0 + mu0n)
3196 :
3197 : ! unpolarized light for direct beam
3198 4760649 : Rf_dir_a = p5 * (R1*R1 + R2*R2)
3199 4760649 : Tf_dir_a = p5 * (T1*T1 + T2*T2)*refindx*mu0n/mu0
3200 :
3201 : ! precalculated diffuse reflectivities and transmissivities
3202 : ! for incident radiation above and below fresnel layer, using
3203 : ! the direct albedos and accounting for complete internal
3204 : ! reflection from below; precalculated because high order
3205 : ! number of gaussian points (~256) is required for convergence:
3206 :
3207 : ! above
3208 4760649 : Rf_dif_a = cp063
3209 4760649 : Tf_dif_a = c1 - Rf_dif_a
3210 : ! below
3211 4760649 : Rf_dif_b = cp455
3212 4760649 : Tf_dif_b = c1 - Rf_dif_b
3213 :
3214 : ! the k = kfrsnl layer properties are updated to combined
3215 : ! the fresnel (refractive) layer, always taken to be above
3216 : ! the present layer k (i.e. be the top interface):
3217 :
3218 4760649 : rintfc = c1 / (c1-Rf_dif_b*rdif_a(k))
3219 2875890 : tdir (k) = Tf_dir_a*tdir(k) &
3220 4760649 : + Tf_dir_a*rdir(k) * Rf_dif_b*rintfc*tdif_a(k)
3221 2875890 : rdir (k) = Rf_dir_a &
3222 4760649 : + Tf_dir_a*rdir (k) * rintfc*Tf_dif_b
3223 2875890 : rdif_a(k) = Rf_dif_a &
3224 4760649 : + Tf_dif_a*rdif_a(k) * rintfc*Tf_dif_b
3225 2875890 : rdif_b(k) = rdif_b(k) &
3226 4760649 : + tdif_b(k)*Rf_dif_b * rintfc*tdif_a(k)
3227 4760649 : tdif_a(k) = tdif_a(k)*rintfc*Tf_dif_a
3228 4760649 : tdif_b(k) = tdif_b(k)*rintfc*Tf_dif_b
3229 :
3230 : ! update trnlay to include fresnel transmission
3231 4760649 : trnlay(k) = Tf_dir_a*trnlay(k)
3232 :
3233 : endif ! k = kfrsnl
3234 :
3235 : endif ! trntdr(k) > trmin
3236 :
3237 : ! initialize current layer properties to zero; only if total
3238 : ! transmission to the top interface of the current layer exceeds the
3239 : ! minimum, will these values be computed below:
3240 : ! Calculate the solar beam transmission, total transmission, and
3241 : ! reflectivity for diffuse radiation from below at interface k,
3242 : ! the top of the current layer k:
3243 : !
3244 : ! layers interface
3245 : !
3246 : ! --------------------- k-1
3247 : ! k-1
3248 : ! --------------------- k
3249 : ! k
3250 : ! ---------------------
3251 : ! For k = klevp
3252 : ! note that we ignore refraction between sea ice and underlying ocean:
3253 : !
3254 : ! layers interface
3255 : !
3256 : ! --------------------- k-1
3257 : ! k-1
3258 : ! --------------------- k
3259 : ! \\\\\\\ ocean \\\\\\\
3260 :
3261 93543630 : trndir(k+1) = trndir(k)*trnlay(k)
3262 93543630 : refkm1 = c1/(c1 - rdndif(k)*rdif_a(k))
3263 93543630 : tdrrdir = trndir(k)*rdir(k)
3264 93543630 : tdndif = trntdr(k) - trndir(k)
3265 54705540 : trntdr(k+1) = trndir(k)*tdir(k) &
3266 148249170 : + (tdndif + tdrrdir*rdndif(k))*refkm1*tdif_a(k)
3267 54705540 : rdndif(k+1) = rdif_b(k) &
3268 148249170 : + (tdif_b(k)*rdndif(k)*refkm1*tdif_a(k))
3269 102897993 : trndif(k+1) = trndif(k)*refkm1*tdif_a(k)
3270 :
3271 : enddo ! k end main level loop
3272 :
3273 : ! compute reflectivity to direct and diffuse radiation for layers
3274 : ! below by adding succesive layers starting from the underlying
3275 : ! ocean and working upwards:
3276 : !
3277 : ! layers interface
3278 : !
3279 : ! --------------------- k
3280 : ! k
3281 : ! --------------------- k+1
3282 : ! k+1
3283 : ! ---------------------
3284 :
3285 9354363 : rupdir(klevp) = albodr
3286 9354363 : rupdif(klevp) = albodf
3287 :
3288 102897993 : do k=klev,0,-1
3289 : ! interface scattering
3290 93543630 : refkp1 = c1/( c1 - rdif_b(k)*rupdif(k+1))
3291 : ! dir from top layer plus exp tran ref from lower layer, interface
3292 : ! scattered and tran thru top layer from below, plus diff tran ref
3293 : ! from lower layer with interface scattering tran thru top from below
3294 54705540 : rupdir(k) = rdir(k) &
3295 : + ( trnlay(k) *rupdir(k+1) & ! LCOV_EXCL_LINE
3296 148249170 : + (tdir(k)-trnlay(k))*rupdif(k+1))*refkp1*tdif_b(k)
3297 : ! dif from top layer from above, plus dif tran upwards reflected and
3298 : ! interface scattered which tran top from below
3299 102897993 : rupdif(k) = rdif_a(k) + tdif_a(k)*rupdif(k+1)*refkp1*tdif_b(k)
3300 : enddo ! k
3301 :
3302 9354363 : end subroutine solution_dEdd
3303 :
3304 : !=======================================================================
3305 : !
3306 : ! Set snow horizontal coverage, density and grain radius diagnostically
3307 : ! for the Delta-Eddington solar radiation method.
3308 : !
3309 : ! author: Bruce P. Briegleb, NCAR
3310 : ! 2013: E Hunke merged with NCAR version
3311 :
3312 34053937 : subroutine shortwave_dEdd_set_snow(R_snw, &
3313 : dT_mlt, rsnw_mlt, & ! LCOV_EXCL_LINE
3314 : aice, vsno, & ! LCOV_EXCL_LINE
3315 : Tsfc, fs, & ! LCOV_EXCL_LINE
3316 : hs0, hs, & ! LCOV_EXCL_LINE
3317 : rhosnw, rsnw, & ! LCOV_EXCL_LINE
3318 34053937 : rsnow)
3319 :
3320 : real (kind=dbl_kind), intent(in) :: &
3321 : R_snw , & ! snow tuning parameter; +1 > ~.01 change in broadband albedo ! LCOV_EXCL_LINE
3322 : dT_mlt, & ! change in temp for non-melt to melt snow grain radius change (C) ! LCOV_EXCL_LINE
3323 : rsnw_mlt ! maximum melting snow grain radius (10^-6 m)
3324 :
3325 : real (kind=dbl_kind), intent(in) :: &
3326 : aice , & ! concentration of ice ! LCOV_EXCL_LINE
3327 : vsno , & ! volume of snow ! LCOV_EXCL_LINE
3328 : Tsfc , & ! surface temperature ! LCOV_EXCL_LINE
3329 : hs0 ! snow depth for transition to bare sea ice (m)
3330 :
3331 : real (kind=dbl_kind), intent(inout) :: &
3332 : fs , & ! horizontal coverage of snow ! LCOV_EXCL_LINE
3333 : hs ! snow depth
3334 :
3335 : real (kind=dbl_kind), dimension (:), intent(in) :: &
3336 : rsnow ! snow grain radius tracer (micro-meters)
3337 :
3338 : real (kind=dbl_kind), dimension (:), intent(out) :: &
3339 : rhosnw , & ! density in snow layer (kg/m3) ! LCOV_EXCL_LINE
3340 : rsnw ! grain radius in snow layer (micro-meters)
3341 :
3342 : ! local variables
3343 :
3344 : integer (kind=int_kind) :: &
3345 : ks ! snow vertical index
3346 :
3347 : real (kind=dbl_kind) :: &
3348 : fT , & ! piecewise linear function of surface temperature ! LCOV_EXCL_LINE
3349 : dTs , & ! difference of Tsfc and Timelt ! LCOV_EXCL_LINE
3350 3103350 : rsnw_nm ! actual used nonmelt snow grain radius (micro-meters)
3351 :
3352 : real (kind=dbl_kind), parameter :: &
3353 : ! units for the following are 1.e-6 m (micro-meters)
3354 : rsnw_nonmelt = 500._dbl_kind, & ! nonmelt snow grain radius
3355 : rsnw_sig = 250._dbl_kind ! assumed sigma for snow grain radius
3356 :
3357 : character(len=*),parameter :: subname='(shortwave_dEdd_set_snow)'
3358 :
3359 : !-----------------------------------------------------------------------
3360 :
3361 : ! set snow horizontal fraction
3362 34053937 : hs = vsno / aice
3363 :
3364 34053937 : if (hs >= hs_min) then
3365 20416172 : fs = c1
3366 20416172 : if (hs0 > puny) fs = min(hs/hs0, c1)
3367 : endif
3368 :
3369 34053937 : if (snwgrain) then ! use snow grain tracer
3370 :
3371 0 : do ks = 1, nslyr
3372 0 : rsnw(ks) = max(rsnw_fall,rsnow(ks))
3373 0 : rsnw(ks) = min(rsnw_tmax,rsnw(ks))
3374 0 : rhosnw(ks) = rhos
3375 : enddo
3376 :
3377 : else
3378 :
3379 : ! bare ice, temperature dependence
3380 34053937 : dTs = Timelt - Tsfc
3381 34053937 : fT = -min(dTs/dT_mlt-c1,c0)
3382 : ! tune nonmelt snow grain radius if desired: note that
3383 : ! the sign is negative so that if R_snw is 1, then the
3384 : ! snow grain radius is reduced and thus albedo increased.
3385 34053937 : rsnw_nm = rsnw_nonmelt - R_snw*rsnw_sig
3386 34053937 : rsnw_nm = max(rsnw_nm, rsnw_fall)
3387 34053937 : rsnw_nm = min(rsnw_nm, rsnw_mlt)
3388 68107874 : do ks = 1, nslyr
3389 : ! snow density ccsm3 constant value
3390 34053937 : rhosnw(ks) = rhos
3391 : ! snow grain radius between rsnw_nonmelt and rsnw_mlt
3392 34053937 : rsnw(ks) = rsnw_nm + (rsnw_mlt-rsnw_nm)*fT
3393 34053937 : rsnw(ks) = max(rsnw(ks), rsnw_fall)
3394 68107874 : rsnw(ks) = min(rsnw(ks), rsnw_mlt)
3395 : enddo ! ks
3396 :
3397 : endif ! snwgrain
3398 :
3399 34053937 : end subroutine shortwave_dEdd_set_snow
3400 :
3401 : !=======================================================================
3402 : !
3403 : ! Set pond fraction and depth diagnostically for
3404 : ! the Delta-Eddington solar radiation method.
3405 : !
3406 : ! author: Bruce P. Briegleb, NCAR
3407 : ! 2013: E Hunke merged with NCAR version
3408 :
3409 0 : subroutine shortwave_dEdd_set_pond(Tsfc, &
3410 : fs, fp, & ! LCOV_EXCL_LINE
3411 : hp)
3412 :
3413 : real (kind=dbl_kind), intent(in) :: &
3414 : Tsfc , & ! surface temperature ! LCOV_EXCL_LINE
3415 : fs ! horizontal coverage of snow
3416 :
3417 : real (kind=dbl_kind), intent(out) :: &
3418 : fp , & ! pond fractional coverage (0 to 1) ! LCOV_EXCL_LINE
3419 : hp ! pond depth (m)
3420 :
3421 : ! local variables
3422 :
3423 : real (kind=dbl_kind) :: &
3424 : fT , & ! piecewise linear function of surface temperature ! LCOV_EXCL_LINE
3425 0 : dTs ! difference of Tsfc and Timelt
3426 :
3427 : real (kind=dbl_kind), parameter :: &
3428 : dT_pnd = c1 ! change in temp for pond fraction and depth
3429 :
3430 : character(len=*),parameter :: subname='(shortwave_dEdd_set_pond)'
3431 :
3432 : !-----------------------------------------------------------------------
3433 :
3434 : ! bare ice, temperature dependence
3435 0 : dTs = Timelt - Tsfc
3436 0 : fT = -min(dTs/dT_pnd-c1,c0)
3437 : ! pond
3438 0 : fp = 0.3_dbl_kind*fT*(c1-fs)
3439 0 : hp = 0.3_dbl_kind*fT*(c1-fs)
3440 :
3441 0 : end subroutine shortwave_dEdd_set_pond
3442 :
3443 : !=======================================================================
3444 : !
3445 : ! authors Nicole Jeffery, LANL
3446 :
3447 0 : subroutine compute_shortwave_trcr(bgcN, zaero, &
3448 : trcrn_bgcsw, sw_grid, & ! LCOV_EXCL_LINE
3449 : hin, hbri, & ! LCOV_EXCL_LINE
3450 : i_grid, skl_bgc, & ! LCOV_EXCL_LINE
3451 : z_tracers)
3452 :
3453 : real (kind=dbl_kind), dimension (:), intent(in) :: &
3454 : bgcN , & ! Nit tracer ! LCOV_EXCL_LINE
3455 : zaero ! zaero tracer
3456 :
3457 : real (kind=dbl_kind), dimension (:), intent(out):: &
3458 : trcrn_bgcsw ! ice on shortwave grid tracers
3459 :
3460 : real (kind=dbl_kind), dimension (:), intent(in) :: &
3461 : sw_grid , & ! ! LCOV_EXCL_LINE
3462 : i_grid ! CICE bio grid
3463 :
3464 : real(kind=dbl_kind), intent(in) :: &
3465 : hin , & ! CICE ice thickness ! LCOV_EXCL_LINE
3466 : hbri ! brine height
3467 :
3468 : logical (kind=log_kind), intent(in) :: &
3469 : skl_bgc , & ! skeletal layer bgc ! LCOV_EXCL_LINE
3470 : z_tracers ! zbgc
3471 :
3472 : ! local variables
3473 :
3474 : integer (kind=int_kind) :: k, n, nn
3475 :
3476 : real (kind=dbl_kind), dimension (ntrcr+2) :: &
3477 : trtmp0, & ! temporary, remapped tracers ! LCOV_EXCL_LINE
3478 0 : trtmp
3479 :
3480 : real (kind=dbl_kind), dimension (nilyr+1):: &
3481 0 : icegrid ! correct for large ice surface layers
3482 :
3483 : real (kind=dbl_kind):: &
3484 0 : top_conc ! 1% (min_bgc) of surface concentration
3485 : ! when hin > hbri: just used in sw calculation
3486 :
3487 : character(len=*),parameter :: subname='(compute_shortwave_trcr)'
3488 :
3489 : !-----------------------------------------------------------------
3490 : ! Compute aerosols and algal chlorophyll on shortwave grid
3491 : !-----------------------------------------------------------------
3492 :
3493 0 : trtmp0(:) = c0
3494 0 : trtmp(:) = c0
3495 0 : trcrn_bgcsw(:) = c0
3496 :
3497 0 : do k = 1,nilyr+1
3498 0 : icegrid(k) = sw_grid(k)
3499 : enddo
3500 0 : if (sw_grid(1)*hin*c2 > hi_ssl) then
3501 0 : icegrid(1) = hi_ssl/c2/hin
3502 : endif
3503 :
3504 0 : if (z_tracers) then
3505 0 : if (tr_bgc_N) then
3506 0 : if (size(bgcN) < n_algae*(nblyr+3)) then
3507 0 : call icepack_warnings_add(subname//' ERROR: size(bgcN) too small')
3508 0 : call icepack_warnings_setabort(.true.,__FILE__,__LINE__)
3509 0 : return
3510 : endif
3511 :
3512 0 : do k = 1, nblyr+1
3513 0 : do n = 1, n_algae
3514 0 : trtmp0(nt_bgc_N(1) + k-1) = trtmp0(nt_bgc_N(1) + k-1) &
3515 0 : + R_chl2N(n) * F_abs_chl(n) * bgcN(nt_bgc_N(n)-nt_bgc_N(1) + k)
3516 : enddo ! n
3517 : enddo ! k
3518 :
3519 0 : top_conc = trtmp0(nt_bgc_N(1))*min_bgc
3520 : call remap_zbgc (nilyr+1, &
3521 : nt_bgc_N(1), & ! LCOV_EXCL_LINE
3522 : trtmp0(1:ntrcr ), & ! LCOV_EXCL_LINE
3523 : trtmp (1:ntrcr+2), & ! LCOV_EXCL_LINE
3524 : 1, nblyr+1, & ! LCOV_EXCL_LINE
3525 : hin, hbri, & ! LCOV_EXCL_LINE
3526 : icegrid(1:nilyr+1), & ! LCOV_EXCL_LINE
3527 0 : i_grid(1:nblyr+1), top_conc )
3528 0 : if (icepack_warnings_aborted(subname)) return
3529 :
3530 0 : do k = 1, nilyr+1
3531 0 : trcrn_bgcsw(nlt_chl_sw+nslyr+k) = trtmp(nt_bgc_N(1) + k-1)
3532 : enddo ! k
3533 :
3534 0 : do n = 1, n_algae ! snow contribution
3535 0 : trcrn_bgcsw(nlt_chl_sw)= trcrn_bgcsw(nlt_chl_sw) &
3536 0 : + R_chl2N(n)*F_abs_chl(n)*bgcN(nt_bgc_N(n)-nt_bgc_N(1)+1+nblyr+1)
3537 : ! snow surface layer
3538 0 : trcrn_bgcsw(nlt_chl_sw+1:nlt_chl_sw+nslyr) = &
3539 : trcrn_bgcsw(nlt_chl_sw+1:nlt_chl_sw+nslyr) & ! LCOV_EXCL_LINE
3540 0 : + R_chl2N(n)*F_abs_chl(n)*bgcN(nt_bgc_N(n)-nt_bgc_N(1)+1+nblyr+2)
3541 : ! only 1 snow layer in zaero
3542 : enddo ! n
3543 : endif ! tr_bgc_N
3544 :
3545 0 : if (tr_zaero) then
3546 0 : if (size(zaero) < n_zaero*(nblyr+3)) then
3547 0 : call icepack_warnings_add(subname//' ERROR: size(zaero) too small')
3548 0 : call icepack_warnings_setabort(.true.,__FILE__,__LINE__)
3549 0 : return
3550 : endif
3551 :
3552 0 : do n = 1, n_zaero
3553 :
3554 0 : trtmp0(:) = c0
3555 0 : trtmp(:) = c0
3556 :
3557 0 : do k = 1, nblyr+1
3558 0 : trtmp0(nt_zaero(n) + k-1) = zaero(nt_zaero(n)-nt_zaero(1)+1+k-1)
3559 : enddo
3560 :
3561 0 : top_conc = trtmp0(nt_zaero(n))*min_bgc
3562 : call remap_zbgc (nilyr+1, &
3563 : nt_zaero(n), & ! LCOV_EXCL_LINE
3564 : trtmp0(1:ntrcr ), & ! LCOV_EXCL_LINE
3565 : trtmp (1:ntrcr+2), & ! LCOV_EXCL_LINE
3566 : 1, nblyr+1, & ! LCOV_EXCL_LINE
3567 : hin, hbri, & ! LCOV_EXCL_LINE
3568 : icegrid(1:nilyr+1), & ! LCOV_EXCL_LINE
3569 0 : i_grid(1:nblyr+1), top_conc )
3570 0 : if (icepack_warnings_aborted(subname)) return
3571 :
3572 0 : do k = 1,nilyr+1
3573 0 : trcrn_bgcsw(nlt_zaero_sw(n)+nslyr+k) = trtmp(nt_zaero(n) + k-1)
3574 : enddo
3575 0 : trcrn_bgcsw(nlt_zaero_sw(n))= zaero(nt_zaero(n)-nt_zaero(1)+1+nblyr+1) !snow ssl
3576 0 : trcrn_bgcsw(nlt_zaero_sw(n)+1:nlt_zaero_sw(n)+nslyr)= zaero(nt_zaero(n)-nt_zaero(1)+1+nblyr+2)
3577 : enddo ! n
3578 : endif ! tr_zaero
3579 0 : elseif (skl_bgc) then
3580 :
3581 0 : do nn = 1,n_algae
3582 0 : trcrn_bgcsw(nbtrcr_sw) = trcrn_bgcsw(nbtrcr_sw) &
3583 : + F_abs_chl(nn)*R_chl2N(nn) & ! LCOV_EXCL_LINE
3584 : * bgcN(nt_bgc_N(nn)-nt_bgc_N(1)+1)*sk_l/hin & ! LCOV_EXCL_LINE
3585 0 : * real(nilyr,kind=dbl_kind)
3586 : enddo
3587 :
3588 : endif
3589 :
3590 : end subroutine compute_shortwave_trcr
3591 :
3592 : !=======================================================================
3593 : !autodocument_start icepack_prep_radiation
3594 : ! Scales radiation fields computed on the previous time step.
3595 : !
3596 : ! authors: Elizabeth Hunke, LANL
3597 :
3598 13119240 : subroutine icepack_prep_radiation(aice, aicen, &
3599 : swvdr, swvdf, & ! LCOV_EXCL_LINE
3600 : swidr, swidf, & ! LCOV_EXCL_LINE
3601 : alvdr_ai, alvdf_ai, & ! LCOV_EXCL_LINE
3602 : alidr_ai, alidf_ai, & ! LCOV_EXCL_LINE
3603 : scale_factor, & ! LCOV_EXCL_LINE
3604 : fswsfcn, fswintn, & ! LCOV_EXCL_LINE
3605 : fswthrun, & ! LCOV_EXCL_LINE
3606 : fswthrun_vdr, & ! LCOV_EXCL_LINE
3607 : fswthrun_vdf, & ! LCOV_EXCL_LINE
3608 : fswthrun_idr, & ! LCOV_EXCL_LINE
3609 : fswthrun_idf, & ! LCOV_EXCL_LINE
3610 : fswpenln, & ! LCOV_EXCL_LINE
3611 13119240 : Sswabsn, Iswabsn)
3612 :
3613 : real (kind=dbl_kind), intent(in) :: &
3614 : aice , & ! ice area fraction ! LCOV_EXCL_LINE
3615 : swvdr , & ! sw down, visible, direct (W/m^2) ! LCOV_EXCL_LINE
3616 : swvdf , & ! sw down, visible, diffuse (W/m^2) ! LCOV_EXCL_LINE
3617 : swidr , & ! sw down, near IR, direct (W/m^2) ! LCOV_EXCL_LINE
3618 : swidf , & ! sw down, near IR, diffuse (W/m^2) ! LCOV_EXCL_LINE
3619 : ! grid-box-mean albedos aggregated over categories (if calc_Tsfc)
3620 : alvdr_ai , & ! visible, direct (fraction)
3621 : alidr_ai , & ! near-ir, direct (fraction) ! LCOV_EXCL_LINE
3622 : alvdf_ai , & ! visible, diffuse (fraction) ! LCOV_EXCL_LINE
3623 : alidf_ai ! near-ir, diffuse (fraction)
3624 :
3625 : real (kind=dbl_kind), dimension(:), intent(in) :: &
3626 : aicen ! ice area fraction in each category
3627 :
3628 : real (kind=dbl_kind), intent(inout) :: &
3629 : scale_factor ! shortwave scaling factor, ratio new:old
3630 :
3631 : real (kind=dbl_kind), dimension(:), intent(inout) :: &
3632 : fswsfcn , & ! SW absorbed at ice/snow surface (W m-2) ! LCOV_EXCL_LINE
3633 : fswintn , & ! SW absorbed in ice interior, below surface (W m-2) ! LCOV_EXCL_LINE
3634 : fswthrun ! SW through ice to ocean (W/m^2)
3635 :
3636 : real (kind=dbl_kind), dimension(:), intent(inout), optional :: &
3637 : fswthrun_vdr , & ! vis dir SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
3638 : fswthrun_vdf , & ! vis dif SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
3639 : fswthrun_idr , & ! nir dir SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
3640 : fswthrun_idf ! nir dif SW through ice to ocean (W/m^2)
3641 :
3642 : real (kind=dbl_kind), dimension(:,:), intent(inout) :: &
3643 : fswpenln , & ! visible SW entering ice layers (W m-2) ! LCOV_EXCL_LINE
3644 : Iswabsn , & ! SW radiation absorbed in ice layers (W m-2) ! LCOV_EXCL_LINE
3645 : Sswabsn ! SW radiation absorbed in snow layers (W m-2)
3646 :
3647 : !autodocument_end
3648 :
3649 : ! local variables
3650 :
3651 : integer (kind=int_kind) :: &
3652 : k , & ! vertical index ! LCOV_EXCL_LINE
3653 : n ! thickness category index
3654 :
3655 4176000 : real (kind=dbl_kind) :: netsw
3656 :
3657 : character(len=*),parameter :: subname='(icepack_prep_radiation)'
3658 :
3659 : !-----------------------------------------------------------------
3660 : ! Compute netsw scaling factor (new netsw / old netsw)
3661 : !-----------------------------------------------------------------
3662 :
3663 13119240 : if (aice > c0 .and. scale_factor > puny) then
3664 : netsw = swvdr*(c1 - alvdr_ai) &
3665 : + swvdf*(c1 - alvdf_ai) & ! LCOV_EXCL_LINE
3666 : + swidr*(c1 - alidr_ai) & ! LCOV_EXCL_LINE
3667 560089 : + swidf*(c1 - alidf_ai)
3668 560089 : scale_factor = netsw / scale_factor
3669 : else
3670 12559151 : scale_factor = c1
3671 : endif
3672 :
3673 78715440 : do n = 1, ncat
3674 :
3675 78715440 : if (aicen(n) > puny) then
3676 :
3677 : !-----------------------------------------------------------------
3678 : ! Scale absorbed solar radiation for change in net shortwave
3679 : !-----------------------------------------------------------------
3680 :
3681 33852099 : fswsfcn(n) = scale_factor * fswsfcn (n)
3682 33852099 : fswintn(n) = scale_factor * fswintn (n)
3683 33852099 : fswthrun(n) = scale_factor * fswthrun(n)
3684 33852099 : if (present(fswthrun_vdr)) fswthrun_vdr(n) = scale_factor * fswthrun_vdr(n)
3685 33852099 : if (present(fswthrun_vdf)) fswthrun_vdf(n) = scale_factor * fswthrun_vdf(n)
3686 33852099 : if (present(fswthrun_idr)) fswthrun_idr(n) = scale_factor * fswthrun_idr(n)
3687 33852099 : if (present(fswthrun_idf)) fswthrun_idf(n) = scale_factor * fswthrun_idf(n)
3688 304668891 : do k = 1,nilyr+1
3689 304668891 : fswpenln(k,n) = scale_factor * fswpenln(k,n)
3690 : enddo !k
3691 67704198 : do k=1,nslyr
3692 67704198 : Sswabsn (k,n) = scale_factor * Sswabsn (k,n)
3693 : enddo
3694 270816792 : do k=1,nilyr
3695 270816792 : Iswabsn (k,n) = scale_factor * Iswabsn (k,n)
3696 : enddo
3697 :
3698 : endif
3699 : enddo ! ncat
3700 :
3701 13119240 : end subroutine icepack_prep_radiation
3702 :
3703 : !=======================================================================
3704 : !autodocument_start icepack_step_radiation
3705 : ! Computes radiation fields
3706 : !
3707 : ! authors: William H. Lipscomb, LANL
3708 : ! David Bailey, NCAR
3709 : ! Elizabeth C. Hunke, LANL
3710 :
3711 10791574 : subroutine icepack_step_radiation (dt, &
3712 : swgrid, igrid, & ! LCOV_EXCL_LINE
3713 : fbri, & ! LCOV_EXCL_LINE
3714 : aicen, vicen, & ! LCOV_EXCL_LINE
3715 : vsnon, Tsfcn, & ! LCOV_EXCL_LINE
3716 : alvln, apndn, & ! LCOV_EXCL_LINE
3717 : hpndn, ipndn, & ! LCOV_EXCL_LINE
3718 : aeron, & ! LCOV_EXCL_LINE
3719 : bgcNn, zaeron, & ! LCOV_EXCL_LINE
3720 : trcrn_bgcsw, & ! LCOV_EXCL_LINE
3721 : TLAT, TLON, & ! LCOV_EXCL_LINE
3722 : calendar_type, & ! LCOV_EXCL_LINE
3723 : days_per_year, & ! LCOV_EXCL_LINE
3724 : nextsw_cday, & ! LCOV_EXCL_LINE
3725 : yday, sec, & ! LCOV_EXCL_LINE
3726 : swvdr, swvdf, & ! LCOV_EXCL_LINE
3727 : swidr, swidf, & ! LCOV_EXCL_LINE
3728 : coszen, fsnow, & ! LCOV_EXCL_LINE
3729 : alvdrn, alvdfn, & ! LCOV_EXCL_LINE
3730 : alidrn, alidfn, & ! LCOV_EXCL_LINE
3731 : fswsfcn, fswintn, & ! LCOV_EXCL_LINE
3732 : fswthrun, & ! LCOV_EXCL_LINE
3733 : fswthrun_vdr, & ! LCOV_EXCL_LINE
3734 : fswthrun_vdf, & ! LCOV_EXCL_LINE
3735 : fswthrun_idr, & ! LCOV_EXCL_LINE
3736 : fswthrun_idf, & ! LCOV_EXCL_LINE
3737 : fswpenln, & ! LCOV_EXCL_LINE
3738 : Sswabsn, Iswabsn, & ! LCOV_EXCL_LINE
3739 : albicen, albsnon, & ! LCOV_EXCL_LINE
3740 : albpndn, apeffn, & ! LCOV_EXCL_LINE
3741 : snowfracn, & ! LCOV_EXCL_LINE
3742 : dhsn, ffracn, & ! LCOV_EXCL_LINE
3743 : rsnow, & ! LCOV_EXCL_LINE
3744 : l_print_point, & ! LCOV_EXCL_LINE
3745 : initonly)
3746 :
3747 : real (kind=dbl_kind), intent(in) :: &
3748 : dt , & ! time step (s) ! LCOV_EXCL_LINE
3749 : swvdr , & ! sw down, visible, direct (W/m^2) ! LCOV_EXCL_LINE
3750 : swvdf , & ! sw down, visible, diffuse (W/m^2) ! LCOV_EXCL_LINE
3751 : swidr , & ! sw down, near IR, direct (W/m^2) ! LCOV_EXCL_LINE
3752 : swidf , & ! sw down, near IR, diffuse (W/m^2) ! LCOV_EXCL_LINE
3753 : fsnow , & ! snowfall rate (kg/m^2 s) ! LCOV_EXCL_LINE
3754 : TLAT, TLON ! latitude and longitude (radian)
3755 :
3756 : integer (kind=int_kind), intent(in) :: &
3757 : sec ! elapsed seconds into date
3758 :
3759 : real (kind=dbl_kind), intent(in) :: &
3760 : yday ! day of the year
3761 :
3762 : character (len=char_len), intent(in), optional :: &
3763 : calendar_type ! differentiates Gregorian from other calendars
3764 :
3765 : integer (kind=int_kind), intent(in), optional :: &
3766 : days_per_year ! number of days in one year
3767 :
3768 : real (kind=dbl_kind), intent(in), optional :: &
3769 : nextsw_cday ! julian day of next shortwave calculation
3770 :
3771 : real (kind=dbl_kind), intent(inout) :: &
3772 : coszen ! cosine solar zenith angle, < 0 for sun below horizon
3773 :
3774 : real (kind=dbl_kind), dimension (:), intent(in) :: &
3775 : igrid ! biology vertical interface points
3776 :
3777 : real (kind=dbl_kind), dimension (:), intent(in) :: &
3778 : swgrid ! grid for ice tracers used in dEdd scheme
3779 :
3780 : real (kind=dbl_kind), dimension(:), intent(in) :: &
3781 : aicen , & ! ice area fraction in each category ! LCOV_EXCL_LINE
3782 : vicen , & ! ice volume in each category (m) ! LCOV_EXCL_LINE
3783 : vsnon , & ! snow volume in each category (m) ! LCOV_EXCL_LINE
3784 : Tsfcn , & ! surface temperature (deg C) ! LCOV_EXCL_LINE
3785 : alvln , & ! level-ice area fraction ! LCOV_EXCL_LINE
3786 : apndn , & ! pond area fraction ! LCOV_EXCL_LINE
3787 : hpndn , & ! pond depth (m) ! LCOV_EXCL_LINE
3788 : ipndn , & ! pond refrozen lid thickness (m) ! LCOV_EXCL_LINE
3789 : fbri ! brine fraction
3790 :
3791 : real(kind=dbl_kind), dimension(:,:), intent(in) :: &
3792 : aeron , & ! aerosols (kg/m^3) ! LCOV_EXCL_LINE
3793 : bgcNn , & ! bgc Nit tracers ! LCOV_EXCL_LINE
3794 : zaeron ! bgcz aero tracers
3795 :
3796 : real(kind=dbl_kind), dimension(:,:), intent(inout) :: &
3797 : trcrn_bgcsw ! zaerosols (kg/m^3) and chla (mg/m^3)
3798 :
3799 : real (kind=dbl_kind), dimension(:), intent(inout) :: &
3800 : alvdrn , & ! visible, direct albedo (fraction) ! LCOV_EXCL_LINE
3801 : alidrn , & ! near-ir, direct (fraction) ! LCOV_EXCL_LINE
3802 : alvdfn , & ! visible, diffuse (fraction) ! LCOV_EXCL_LINE
3803 : alidfn , & ! near-ir, diffuse (fraction) ! LCOV_EXCL_LINE
3804 : fswsfcn , & ! SW absorbed at ice/snow surface (W m-2) ! LCOV_EXCL_LINE
3805 : fswintn , & ! SW absorbed in ice interior, below surface (W m-2) ! LCOV_EXCL_LINE
3806 : fswthrun , & ! SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
3807 : snowfracn , & ! snow fraction on each category ! LCOV_EXCL_LINE
3808 : dhsn , & ! depth difference for snow on sea ice and pond ice ! LCOV_EXCL_LINE
3809 : ffracn , & ! fraction of fsurfn used to melt ipond ! LCOV_EXCL_LINE
3810 : ! albedo components for history
3811 : albicen , & ! bare ice
3812 : albsnon , & ! snow ! LCOV_EXCL_LINE
3813 : albpndn , & ! pond ! LCOV_EXCL_LINE
3814 : apeffn ! effective pond area used for radiation calculation
3815 :
3816 : real (kind=dbl_kind), dimension(:), intent(inout), optional :: &
3817 : fswthrun_vdr , & ! vis dir SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
3818 : fswthrun_vdf , & ! vis dif SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
3819 : fswthrun_idr , & ! nir dir SW through ice to ocean (W/m^2) ! LCOV_EXCL_LINE
3820 : fswthrun_idf ! nir dif SW through ice to ocean (W/m^2)
3821 :
3822 : real (kind=dbl_kind), dimension(:,:), intent(inout) :: &
3823 : fswpenln , & ! visible SW entering ice layers (W m-2) ! LCOV_EXCL_LINE
3824 : Iswabsn , & ! SW radiation absorbed in ice layers (W m-2) ! LCOV_EXCL_LINE
3825 : Sswabsn ! SW radiation absorbed in snow layers (W m-2)
3826 :
3827 : logical (kind=log_kind), intent(in) :: &
3828 : l_print_point ! flag for printing diagnostics
3829 :
3830 : real (kind=dbl_kind), dimension(:,:), intent(inout), optional :: &
3831 : rsnow ! snow grain radius tracer (10^-6 m)
3832 :
3833 : logical (kind=log_kind), optional :: &
3834 : initonly ! flag to indicate init only, default is false
3835 :
3836 : !autodocument_end
3837 :
3838 : ! local variables
3839 :
3840 : integer (kind=int_kind) :: &
3841 : n ! thickness category index
3842 :
3843 : logical (kind=log_kind), save :: &
3844 : first_call=.true. ! first call logical
3845 :
3846 : real(kind=dbl_kind) :: &
3847 : hin, & ! Ice thickness (m) ! LCOV_EXCL_LINE
3848 2898172 : hbri ! brine thickness (m)
3849 :
3850 : character(len=*),parameter :: subname='(icepack_step_radiation)'
3851 :
3852 10791574 : if ((first_call .and. argcheck == 'first') .or. (argcheck == 'always')) then
3853 37 : if (snwgrain .and. .not. present(rsnow)) then
3854 0 : call icepack_warnings_add(subname//' ERROR: snwgrain on, rsnow not passed')
3855 0 : call icepack_warnings_setabort(.true.,__FILE__,__LINE__)
3856 0 : return
3857 : endif
3858 : #ifdef CESMCOUPLED
3859 : if (.not.present(days_per_year) .or. &
3860 : .not.present(nextsw_cday) .or. & ! LCOV_EXCL_LINE
3861 : .not.present(calendar_type)) then
3862 : call icepack_warnings_add(subname//' ERROR: CESMCOUPLED CPP on, need more calendar data')
3863 : call icepack_warnings_setabort(.true.,__FILE__,__LINE__)
3864 : return
3865 : endif
3866 : #endif
3867 : endif
3868 :
3869 10791574 : hin = c0
3870 10791574 : hbri = c0
3871 :
3872 : ! Initialize
3873 64749444 : do n = 1, ncat
3874 53957870 : alvdrn (n) = c0
3875 53957870 : alidrn (n) = c0
3876 53957870 : alvdfn (n) = c0
3877 53957870 : alidfn (n) = c0
3878 53957870 : fswsfcn (n) = c0
3879 53957870 : fswintn (n) = c0
3880 64749444 : fswthrun(n) = c0
3881 : enddo ! ncat
3882 496412404 : fswpenln (:,:) = c0
3883 442454534 : Iswabsn (:,:) = c0
3884 118707314 : Sswabsn (:,:) = c0
3885 118707314 : trcrn_bgcsw(:,:) = c0
3886 :
3887 : ! Interpolate z-shortwave tracers to shortwave grid
3888 10791574 : if (dEdd_algae) then
3889 0 : do n = 1, ncat
3890 0 : if (aicen(n) .gt. puny) then
3891 0 : hin = vicen(n)/aicen(n)
3892 0 : hbri= fbri(n)*hin
3893 : call compute_shortwave_trcr( &
3894 : bgcNn(:,n), & ! LCOV_EXCL_LINE
3895 : zaeron(:,n), & ! LCOV_EXCL_LINE
3896 : trcrn_bgcsw(:,n), & ! LCOV_EXCL_LINE
3897 : swgrid, hin, & ! LCOV_EXCL_LINE
3898 : hbri, & ! LCOV_EXCL_LINE
3899 : igrid, & ! LCOV_EXCL_LINE
3900 0 : skl_bgc, z_tracers )
3901 0 : if (icepack_warnings_aborted(subname)) return
3902 : endif
3903 : enddo
3904 : endif
3905 :
3906 10791574 : if (calc_Tsfc) then
3907 10791574 : if (trim(shortwave(1:4)) == 'dEdd') then ! delta Eddington
3908 :
3909 : call run_dEdd(dt, &
3910 : aicen, vicen, & ! LCOV_EXCL_LINE
3911 : vsnon, Tsfcn, & ! LCOV_EXCL_LINE
3912 : alvln, apndn, & ! LCOV_EXCL_LINE
3913 : hpndn, ipndn, & ! LCOV_EXCL_LINE
3914 : aeron, & ! LCOV_EXCL_LINE
3915 : trcrn_bgcsw, & ! LCOV_EXCL_LINE
3916 : TLAT, TLON, & ! LCOV_EXCL_LINE
3917 : calendar_type,days_per_year, & ! LCOV_EXCL_LINE
3918 : nextsw_cday, yday, & ! LCOV_EXCL_LINE
3919 : sec, & ! LCOV_EXCL_LINE
3920 : swvdr, swvdf, & ! LCOV_EXCL_LINE
3921 : swidr, swidf, & ! LCOV_EXCL_LINE
3922 : coszen, fsnow, & ! LCOV_EXCL_LINE
3923 : alvdrn, alvdfn, & ! LCOV_EXCL_LINE
3924 : alidrn, alidfn, & ! LCOV_EXCL_LINE
3925 : fswsfcn, fswintn, & ! LCOV_EXCL_LINE
3926 : fswthrun=fswthrun, & ! LCOV_EXCL_LINE
3927 : fswthrun_vdr=fswthrun_vdr, & ! LCOV_EXCL_LINE
3928 : fswthrun_vdf=fswthrun_vdf, & ! LCOV_EXCL_LINE
3929 : fswthrun_idr=fswthrun_idr, & ! LCOV_EXCL_LINE
3930 : fswthrun_idf=fswthrun_idf, & ! LCOV_EXCL_LINE
3931 : fswpenln=fswpenln, & ! LCOV_EXCL_LINE
3932 : Sswabsn=Sswabsn, & ! LCOV_EXCL_LINE
3933 : Iswabsn=Iswabsn, & ! LCOV_EXCL_LINE
3934 : albicen=albicen, & ! LCOV_EXCL_LINE
3935 : albsnon=albsnon, & ! LCOV_EXCL_LINE
3936 : albpndn=albpndn, & ! LCOV_EXCL_LINE
3937 : apeffn=apeffn, & ! LCOV_EXCL_LINE
3938 : snowfracn=snowfracn, & ! LCOV_EXCL_LINE
3939 : dhsn=dhsn, & ! LCOV_EXCL_LINE
3940 : ffracn=ffracn, & ! LCOV_EXCL_LINE
3941 : rsnow=rsnow, & ! LCOV_EXCL_LINE
3942 : l_print_point=l_print_point, & ! LCOV_EXCL_LINE
3943 10791574 : initonly=initonly)
3944 10791574 : if (icepack_warnings_aborted(subname)) return
3945 :
3946 0 : elseif (trim(shortwave(1:4)) == 'ccsm') then
3947 :
3948 0 : call shortwave_ccsm3(aicen, vicen, &
3949 : vsnon, & ! LCOV_EXCL_LINE
3950 : Tsfcn, & ! LCOV_EXCL_LINE
3951 : swvdr, swvdf, & ! LCOV_EXCL_LINE
3952 : swidr, swidf, & ! LCOV_EXCL_LINE
3953 : albedo_type, & ! LCOV_EXCL_LINE
3954 : albicev, albicei, & ! LCOV_EXCL_LINE
3955 : albsnowv, albsnowi, & ! LCOV_EXCL_LINE
3956 : ahmax, & ! LCOV_EXCL_LINE
3957 : alvdrn, alidrn, & ! LCOV_EXCL_LINE
3958 : alvdfn, alidfn, & ! LCOV_EXCL_LINE
3959 : fswsfcn, fswintn, & ! LCOV_EXCL_LINE
3960 : fswthrun=fswthrun, & ! LCOV_EXCL_LINE
3961 : fswthrun_vdr=fswthrun_vdr,& ! LCOV_EXCL_LINE
3962 : fswthrun_vdf=fswthrun_vdf,& ! LCOV_EXCL_LINE
3963 : fswthrun_idr=fswthrun_idr,& ! LCOV_EXCL_LINE
3964 : fswthrun_idf=fswthrun_idf,& ! LCOV_EXCL_LINE
3965 : fswpenl=fswpenln, & ! LCOV_EXCL_LINE
3966 : Iswabs=Iswabsn, & ! LCOV_EXCL_LINE
3967 : Sswabs=Sswabsn, & ! LCOV_EXCL_LINE
3968 : albin=albicen, & ! LCOV_EXCL_LINE
3969 : albsn=albsnon, & ! LCOV_EXCL_LINE
3970 0 : coszen=coszen)
3971 0 : if (icepack_warnings_aborted(subname)) return
3972 :
3973 : else
3974 :
3975 0 : call icepack_warnings_add(subname//' ERROR: shortwave '//trim(shortwave)//' unknown')
3976 0 : call icepack_warnings_setabort(.true.,__FILE__,__LINE__)
3977 0 : return
3978 :
3979 : endif ! shortwave
3980 :
3981 : else ! .not. calc_Tsfc
3982 :
3983 : ! Calculate effective pond area for HadGEM
3984 :
3985 0 : if (tr_pond_topo) then
3986 0 : do n = 1, ncat
3987 0 : apeffn(n) = c0
3988 0 : if (aicen(n) > puny) then
3989 : ! Lid effective if thicker than hp1
3990 0 : if (apndn(n)*aicen(n) > puny .and. ipndn(n) < hp1) then
3991 0 : apeffn(n) = apndn(n)
3992 : else
3993 0 : apeffn(n) = c0
3994 : endif
3995 0 : if (apndn(n) < puny) apeffn(n) = c0
3996 : endif
3997 : enddo ! ncat
3998 :
3999 : endif ! tr_pond_topo
4000 :
4001 : ! Initialize for safety
4002 0 : do n = 1, ncat
4003 0 : alvdrn (n) = c0
4004 0 : alidrn (n) = c0
4005 0 : alvdfn (n) = c0
4006 0 : alidfn (n) = c0
4007 0 : fswsfcn (n) = c0
4008 0 : fswintn (n) = c0
4009 0 : fswthrun(n) = c0
4010 : enddo ! ncat
4011 0 : Iswabsn (:,:) = c0
4012 0 : Sswabsn (:,:) = c0
4013 :
4014 : endif ! calc_Tsfc
4015 :
4016 10791574 : first_call = .false.
4017 :
4018 : end subroutine icepack_step_radiation
4019 :
4020 : !=======================================================================
4021 :
4022 : ! Delta-Eddington solution expressions
4023 :
4024 : !=======================================================================
4025 :
4026 409639392 : real(kind=dbl_kind) function alpha(w,uu,gg,e)
4027 :
4028 : real(kind=dbl_kind), intent(in) :: w, uu, gg, e
4029 :
4030 409639392 : alpha = p75*w*uu*((c1 + gg*(c1-w))/(c1 - e*e*uu*uu))
4031 :
4032 412537564 : end function alpha
4033 :
4034 : !=======================================================================
4035 :
4036 409639392 : real(kind=dbl_kind) function agamm(w,uu,gg,e)
4037 :
4038 : real(kind=dbl_kind), intent(in) :: w, uu, gg, e
4039 :
4040 409639392 : agamm = p5*w*((c1 + c3*gg*(c1-w)*uu*uu)/(c1-e*e*uu*uu))
4041 :
4042 409639392 : end function agamm
4043 :
4044 : !=======================================================================
4045 :
4046 45515488 : real(kind=dbl_kind) function n(uu,et)
4047 :
4048 : real(kind=dbl_kind), intent(in) :: uu, et
4049 :
4050 45515488 : n = ((uu+c1)*(uu+c1)/et) - ((uu-c1)*(uu-c1)*et)
4051 :
4052 45515488 : end function n
4053 :
4054 : !=======================================================================
4055 :
4056 45515488 : real(kind=dbl_kind) function u(w,gg,e)
4057 :
4058 : real(kind=dbl_kind), intent(in) :: w, gg, e
4059 :
4060 45515488 : u = c1p5*(c1 - w*gg)/e
4061 :
4062 45515488 : end function u
4063 :
4064 : !=======================================================================
4065 :
4066 45515488 : real(kind=dbl_kind) function el(w,gg)
4067 :
4068 : real(kind=dbl_kind), intent(in) :: w, gg
4069 :
4070 45515488 : el = sqrt(c3*(c1-w)*(c1 - w*gg))
4071 :
4072 45515488 : end function el
4073 :
4074 : !=======================================================================
4075 :
4076 45515488 : real(kind=dbl_kind) function taus(w,f,t)
4077 :
4078 : real(kind=dbl_kind), intent(in) :: w, f, t
4079 :
4080 45515488 : taus = (c1 - w*f)*t
4081 :
4082 45515488 : end function taus
4083 :
4084 : !=======================================================================
4085 :
4086 45515488 : real(kind=dbl_kind) function omgs(w,f)
4087 :
4088 : real(kind=dbl_kind), intent(in) :: w, f
4089 :
4090 45515488 : omgs = (c1 - f)*w/(c1 - w*f)
4091 :
4092 45515488 : end function omgs
4093 :
4094 : !=======================================================================
4095 :
4096 45515488 : real(kind=dbl_kind) function asys(gg,f)
4097 :
4098 : real(kind=dbl_kind), intent(in) :: gg, f
4099 :
4100 45515488 : asys = (gg - f)/(c1 - f)
4101 :
4102 45515488 : end function asys
4103 :
4104 : !=======================================================================
4105 : ! --- Begin 5 band dEdd subroutine ---
4106 : ! Evaluate snow/ice/ponded ice inherent optical properties (IOPs), and
4107 : ! then calculate the multiple scattering solution by calling solution_dEdd.
4108 : !
4109 : ! author: Bruce P. Briegleb, NCAR
4110 : ! 2013: E Hunke merged with NCAR version
4111 : ! 2018: Cheng Dang merged with SNICAR 5-band snow and aersols IOPs, UC Irvine
4112 : !
4113 : ! Note by Cheng Dang 2018:
4114 : ! This subroutine kept the existing delta-eddington adding-doubling (-ad)
4115 : ! method, snow and sea ice layer sturcture, and most of the code structures
4116 : ! of subroutine compute_dEdd_3bd, with major changes listed below to merge
4117 : ! current snow treatments in SNICAR Model
4118 : ! 1. The shortwave radiative transfer properties of snow-covered sea ice are
4119 : ! calculated for 5 bands (1 visible and 4 near-IR) defined in SNICAR.
4120 : ! 2. The reflection/absorption/transmission of direct and diffuse shortwave
4121 : ! incidents are calculated separately to remove the snow grain adjustment
4122 : ! in subroutine compute_dEdd_3bd.
4123 : ! 3. The albedo and absorption of snow-covered sea ice are adjusted when the
4124 : ! solar zenith angle is above 75 degrees.
4125 : ! 4. Comments given in subroutine compute_dEdd_3bd are all kept in this subroutine
4126 : ! with modifications for the changes above.
4127 : !
4128 : ! Justification and explanation of these changes can be found in
4129 : ! Dang, C., Zender, C. S., and Flanner, M. G.: Intercomparison and improvement
4130 : ! of two-stream shortwave radiative transfer schemes in Earth system models
4131 : ! for a unified treatment of cryospheric surfaces, The Cryosphere, 13,
4132 : ! 2325-2343, https://doi.org/10.5194/tc-13-2325-2019, 2019.
4133 :
4134 0 : subroutine compute_dEdd_5bd( &
4135 : klev, klevp, zbio, fnidr, coszen, & ! LCOV_EXCL_LINE
4136 : swvdr, swvdf, swidr, swidf, srftyp, & ! LCOV_EXCL_LINE
4137 : hs, rhosnw, rsnw, hi, hp, & ! LCOV_EXCL_LINE
4138 : fi, aero_mp, alvdr, alvdf, & ! LCOV_EXCL_LINE
4139 : alidr, alidf, fswsfc, fswint, fswthru, & ! LCOV_EXCL_LINE
4140 : fswthru_vdr, fswthru_vdf, & ! LCOV_EXCL_LINE
4141 : fswthru_idr, fswthru_idf, & ! LCOV_EXCL_LINE
4142 0 : Sswabs, Iswabs, fswpenl )
4143 :
4144 : integer (kind=int_kind), intent(in) :: &
4145 : klev , & ! number of radiation layers - 1 ! LCOV_EXCL_LINE
4146 : klevp ! number of radiation interfaces - 1
4147 : ! (0 layer is included also)
4148 :
4149 : real (kind=dbl_kind), intent(in) :: &
4150 : fnidr , & ! fraction of direct to total down flux in nir ! LCOV_EXCL_LINE
4151 : coszen, & ! cosine solar zenith angle ! LCOV_EXCL_LINE
4152 : swvdr , & ! shortwave down at surface, visible, direct (W/m^2) ! LCOV_EXCL_LINE
4153 : swvdf , & ! shortwave down at surface, visible, diffuse (W/m^2) ! LCOV_EXCL_LINE
4154 : swidr , & ! shortwave down at surface, near IR, direct (W/m^2) ! LCOV_EXCL_LINE
4155 : swidf ! shortwave down at surface, near IR, diffuse (W/m^2)
4156 :
4157 : integer (kind=int_kind), intent(in) :: &
4158 : srftyp ! surface type over ice: (0=air, 1=snow, 2=pond)
4159 :
4160 : real (kind=dbl_kind), intent(in) :: &
4161 : hs ! snow thickness (m)
4162 :
4163 : real (kind=dbl_kind), dimension (:), intent(in) :: &
4164 : rhosnw, & ! snow density in snow layer (kg/m3) ! LCOV_EXCL_LINE
4165 : rsnw , & ! snow grain radius in snow layer (m) ! LCOV_EXCL_LINE
4166 : zbio , & ! zaerosol + chla shortwave tracers kg/m^3 ! LCOV_EXCL_LINE
4167 : aero_mp ! aerosol mass path in kg/m2
4168 :
4169 : real (kind=dbl_kind), intent(in) :: &
4170 : hi , & ! ice thickness (m) ! LCOV_EXCL_LINE
4171 : hp , & ! pond depth (m) ! LCOV_EXCL_LINE
4172 : fi ! snow/bare ice fractional coverage (0 to 1)
4173 :
4174 : real (kind=dbl_kind), intent(inout) :: &
4175 : alvdr , & ! visible, direct, albedo (fraction) ! LCOV_EXCL_LINE
4176 : alvdf , & ! visible, diffuse, albedo (fraction) ! LCOV_EXCL_LINE
4177 : alidr , & ! near-ir, direct, albedo (fraction) ! LCOV_EXCL_LINE
4178 : alidf , & ! near-ir, diffuse, albedo (fraction) ! LCOV_EXCL_LINE
4179 : fswsfc, & ! SW absorbed at snow/bare ice/pondedi ice surface (W m-2) ! LCOV_EXCL_LINE
4180 : fswint, & ! SW interior absorption (below surface, above ocean,W m-2) ! LCOV_EXCL_LINE
4181 : fswthru ! SW through snow/bare ice/ponded ice into ocean (W m-2)
4182 :
4183 : real (kind=dbl_kind), intent(inout) :: &
4184 : fswthru_vdr, & ! vis dir SW through snow/bare ice/ponded ice into ocean (W m-2) ! LCOV_EXCL_LINE
4185 : fswthru_vdf, & ! vis dif SW through snow/bare ice/ponded ice into ocean (W m-2) ! LCOV_EXCL_LINE
4186 : fswthru_idr, & ! nir dir SW through snow/bare ice/ponded ice into ocean (W m-2) ! LCOV_EXCL_LINE
4187 : fswthru_idf ! nir dif SW through snow/bare ice/ponded ice into ocean (W m-2)
4188 :
4189 : real (kind=dbl_kind), dimension (:), intent(inout) :: &
4190 : fswpenl, & ! visible SW entering ice layers (W m-2) ! LCOV_EXCL_LINE
4191 : Sswabs , & ! SW absorbed in snow layer (W m-2) ! LCOV_EXCL_LINE
4192 : Iswabs ! SW absorbed in ice layer (W m-2)
4193 :
4194 : !-----------------------------------------------------------------------
4195 : ! Set up optical property profiles, based on snow, sea ice and ponded
4196 : ! ice IOPs from:
4197 : !
4198 : ! Briegleb, B. P., and B. Light (2007): A Delta-Eddington Multiple
4199 : ! Scattering Parameterization for Solar Radiation in the Sea Ice
4200 : ! Component of the Community Climate System Model, NCAR Technical
4201 : ! Note NCAR/TN-472+STR February 2007
4202 : !
4203 : ! Computes column Delta-Eddington radiation solution for specific
4204 : ! surface type: either snow over sea ice, bare sea ice, or ponded sea ice.
4205 : !
4206 : ! Divides solar spectrum into 3 intervals: 0.2-0.7, 0.7-1.19, and
4207 : ! 1.19-5.0 micro-meters. The latter two are added (using an assumed
4208 : ! partition of incident shortwave in the 0.7-5.0 micro-meter band between
4209 : ! the 0.7-1.19 and 1.19-5.0 micro-meter band) to give the final output
4210 : ! of 0.2-0.7 visible and 0.7-5.0 near-infrared albedos and fluxes.
4211 : !
4212 : ! Specifies vertical layer optical properties based on input snow depth,
4213 : ! density and grain radius, along with ice and pond depths, then computes
4214 : ! layer by layer Delta-Eddington reflectivity, transmissivity and combines
4215 : ! layers (done by calling routine solution_dEdd). Finally, surface albedos
4216 : ! and internal fluxes/flux divergences are evaluated.
4217 : !
4218 : ! Description of the level and layer index conventions. This is
4219 : ! for the standard case of one snow layer and four sea ice layers.
4220 : !
4221 : ! Please read the following; otherwise, there is 99.9% chance you
4222 : ! will be confused about indices at some point in time........ :)
4223 : !
4224 : ! CICE4.0 snow treatment has one snow layer above the sea ice. This
4225 : ! snow layer has finite heat capacity, so that surface absorption must
4226 : ! be distinguished from internal. The Delta-Eddington solar radiation
4227 : ! thus adds extra surface scattering layers to both snow and sea ice.
4228 : ! Note that in the following, we assume a fixed vertical layer structure
4229 : ! for the radiation calculation. In other words, we always have the
4230 : ! structure shown below for one snow and four sea ice layers, but for
4231 : ! ponded ice the pond fills "snow" layer 1 over the sea ice, and for
4232 : ! bare sea ice the top layers over sea ice are treated as transparent air.
4233 : !
4234 : ! SSL = surface scattering layer for either snow or sea ice
4235 : ! DL = drained layer for sea ice immediately under sea ice SSL
4236 : ! INT = interior layers for sea ice below the drained layer.
4237 : !
4238 : ! Notice that the radiation level starts with 0 at the top. Thus,
4239 : ! the total number radiation layers is klev+1, where klev is the
4240 : ! sum of nslyr, the number of CCSM snow layers, and nilyr, the
4241 : ! number of CCSM sea ice layers, plus the sea ice SSL:
4242 : ! klev = 1 + nslyr + nilyr
4243 : !
4244 : ! For the standard case illustrated below, nslyr=1, nilyr=4,
4245 : ! and klev=6, with the number of layer interfaces klevp=klev+1.
4246 : ! Layer interfaces are the surfaces on which reflectivities,
4247 : ! transmissivities and fluxes are evaluated.
4248 : !
4249 : ! CCSM3 Sea Ice Model Delta-Eddington Solar Radiation
4250 : ! Layers and Interfaces
4251 : ! Layer Index Interface Index
4252 : ! --------------------- --------------------- 0
4253 : ! 0 \\\ snow SSL \\\
4254 : ! snow layer 1 --------------------- 1
4255 : ! 1 rest of snow layer
4256 : ! +++++++++++++++++++++ +++++++++++++++++++++ 2
4257 : ! 2 \\\ sea ice SSL \\\
4258 : ! sea ice layer 1 --------------------- 3
4259 : ! 3 sea ice DL
4260 : ! --------------------- --------------------- 4
4261 : !
4262 : ! sea ice layer 2 4 sea ice INT
4263 : !
4264 : ! --------------------- --------------------- 5
4265 : !
4266 : ! sea ice layer 3 5 sea ice INT
4267 : !
4268 : ! --------------------- --------------------- 6
4269 : !
4270 : ! sea ice layer 4 6 sea ice INT
4271 : !
4272 : ! --------------------- --------------------- 7
4273 : !
4274 : ! When snow lies over sea ice, the radiation absorbed in the
4275 : ! snow SSL is used for surface heating, and that in the rest
4276 : ! of the snow layer for its internal heating. For sea ice in
4277 : ! this case, all of the radiant heat absorbed in both the
4278 : ! sea ice SSL and the DL are used for sea ice layer 1 heating.
4279 : !
4280 : ! When pond lies over sea ice, and for bare sea ice, all of the
4281 : ! radiant heat absorbed within and above the sea ice SSL is used
4282 : ! for surface heating, and that absorbed in the sea ice DL is
4283 : ! used for sea ice layer 1 heating.
4284 : !
4285 : ! Basically, vertical profiles of the layer extinction optical depth (tau),
4286 : ! single scattering albedo (w0) and asymmetry parameter (g) are required over
4287 : ! the klev+1 layers, where klev+1 = 2 + nslyr + nilyr. All of the surface type
4288 : ! information and snow/ice iop properties are evaulated in this routine, so
4289 : ! the tau,w0,g profiles can be passed to solution_dEdd for multiple scattering
4290 : ! evaluation. Snow, bare ice and ponded ice iops are contained in data arrays
4291 : ! in this routine.
4292 : !
4293 : !-----------------------------------------------------------------------
4294 :
4295 : ! local variables
4296 :
4297 : integer (kind=int_kind) :: &
4298 : k , & ! level index ! LCOV_EXCL_LINE
4299 : ns , & ! spectral index ! LCOV_EXCL_LINE
4300 : nr , & ! index for grain radius tables ! LCOV_EXCL_LINE
4301 : ki , & ! index for internal absorption ! LCOV_EXCL_LINE
4302 : km , & ! k starting index for snow, sea ice internal absorption ! LCOV_EXCL_LINE
4303 : kp , & ! k+1 or k+2 index for snow, sea ice internal absorption ! LCOV_EXCL_LINE
4304 : ksrf , & ! level index for surface absorption ! LCOV_EXCL_LINE
4305 : ksnow , & ! level index for snow density and grain size ! LCOV_EXCL_LINE
4306 : kii ! level starting index for sea ice (nslyr+1)
4307 :
4308 : real (kind=dbl_kind) :: &
4309 : avdr , & ! visible albedo, direct (fraction) ! LCOV_EXCL_LINE
4310 : avdf , & ! visible albedo, diffuse (fraction) ! LCOV_EXCL_LINE
4311 : aidr , & ! near-ir albedo, direct (fraction) ! LCOV_EXCL_LINE
4312 0 : aidf ! near-ir albedo, diffuse (fraction)
4313 :
4314 : real (kind=dbl_kind) :: &
4315 : fsfc , & ! shortwave absorbed at snow/bare ice/ponded ice surface (W m-2) ! LCOV_EXCL_LINE
4316 : fint , & ! shortwave absorbed in interior (W m-2) ! LCOV_EXCL_LINE
4317 : fthru , & ! shortwave through snow/bare ice/ponded ice to ocean (W/m^2) ! LCOV_EXCL_LINE
4318 : fthruvdr, & ! vis dir shortwave through snow/bare ice/ponded ice to ocean (W/m^2) ! LCOV_EXCL_LINE
4319 : fthruvdf, & ! vis dif shortwave through snow/bare ice/ponded ice to ocean (W/m^2) ! LCOV_EXCL_LINE
4320 : fthruidr, & ! nir dir shortwave through snow/bare ice/ponded ice to ocean (W/m^2) ! LCOV_EXCL_LINE
4321 0 : fthruidf ! nir dif shortwave through snow/bare ice/ponded ice to ocean (W/m^2)
4322 :
4323 : real (kind=dbl_kind), dimension(nslyr) :: &
4324 0 : Sabs ! shortwave absorbed in snow layer (W m-2)
4325 :
4326 : real (kind=dbl_kind), dimension(nilyr) :: &
4327 0 : Iabs ! shortwave absorbed in ice layer (W m-2)
4328 :
4329 : real (kind=dbl_kind), dimension(nilyr+1) :: &
4330 0 : fthrul ! shortwave through to ice layers (W m-2)
4331 :
4332 : real (kind=dbl_kind), parameter :: &
4333 : cp67 = 0.67_dbl_kind, & ! nir band weight parameter ! LCOV_EXCL_LINE
4334 : cp33 = 0.33_dbl_kind, & ! nir band weight parameter ! LCOV_EXCL_LINE
4335 : cp78 = 0.78_dbl_kind, & ! nir band weight parameter ! LCOV_EXCL_LINE
4336 : cp22 = 0.22_dbl_kind, & ! nir band weight parameter ! LCOV_EXCL_LINE
4337 : cp01 = 0.01_dbl_kind ! for ocean visible albedo
4338 :
4339 : real (kind=dbl_kind), dimension (0:klev) :: &
4340 : tau , & ! layer extinction optical depth ! LCOV_EXCL_LINE
4341 : w0 , & ! layer single scattering albedo ! LCOV_EXCL_LINE
4342 0 : g ! layer asymmetry parameter
4343 :
4344 : ! following arrays are defined at model interfaces; 0 is the top of the
4345 : ! layer above the sea ice; klevp is the sea ice/ocean interface.
4346 : real (kind=dbl_kind), dimension (0:klevp) :: &
4347 : trndir , & ! solar beam down transmission from top ! LCOV_EXCL_LINE
4348 : trntdr , & ! total transmission to direct beam for layers above ! LCOV_EXCL_LINE
4349 : trndif , & ! diffuse transmission to diffuse beam for layers above ! LCOV_EXCL_LINE
4350 : rupdir , & ! reflectivity to direct radiation for layers below ! LCOV_EXCL_LINE
4351 : rupdif , & ! reflectivity to diffuse radiation for layers below ! LCOV_EXCL_LINE
4352 0 : rdndif ! reflectivity to diffuse radiation for layers above
4353 :
4354 : real (kind=dbl_kind), dimension (0:klevp) :: &
4355 : dfdir , & ! down-up flux at interface due to direct beam at top surface ! LCOV_EXCL_LINE
4356 0 : dfdif ! down-up flux at interface due to diffuse beam at top surface
4357 :
4358 : real (kind=dbl_kind) :: &
4359 : refk , & ! interface k multiple scattering term ! LCOV_EXCL_LINE
4360 : delr , & ! snow grain radius interpolation parameter ! LCOV_EXCL_LINE
4361 : ! inherent optical properties (iop) for snow
4362 : Qs , & ! Snow extinction efficiency
4363 : ks , & ! Snow mass extinction coefficient (m^2/kg) ! LCOV_EXCL_LINE
4364 : ws , & ! Snow single scattering albedo ! LCOV_EXCL_LINE
4365 0 : gs ! Snow asymmetry parameter
4366 :
4367 : ! real (kind=dbl_kind), dimension(nslyr) :: &
4368 : ! frsnw ! snow grain radius in snow layer * adjustment factor (m)
4369 :
4370 : real (kind=dbl_kind), dimension(0:klev) :: &
4371 0 : dzk ! layer thickness
4372 :
4373 : real (kind=dbl_kind) :: &
4374 : dz , & ! snow, sea ice or pond water layer thickness ! LCOV_EXCL_LINE
4375 : dz_ssl , & ! snow or sea ice surface scattering layer thickness ! LCOV_EXCL_LINE
4376 0 : fs ! scaling factor to reduce (nilyr<4) or increase (nilyr>4) DL
4377 : ! extinction coefficient to maintain DL optical depth constant
4378 : ! with changing number of sea ice layers, to approximately
4379 : ! conserve computed albedo for constant physical depth of sea
4380 : ! ice when the number of sea ice layers vary
4381 :
4382 : real (kind=dbl_kind) :: &
4383 : sig , & ! scattering coefficient for tuning ! LCOV_EXCL_LINE
4384 : kabs , & ! absorption coefficient for tuning ! LCOV_EXCL_LINE
4385 0 : sigp ! modified scattering coefficient for tuning
4386 :
4387 : real (kind=dbl_kind) :: &
4388 : albodr , & ! spectral ocean albedo to direct rad ! LCOV_EXCL_LINE
4389 0 : albodf ! spectral ocean albedo to diffuse rad
4390 :
4391 : ! for melt pond transition to bare sea ice for small pond depths
4392 : real (kind=dbl_kind) :: &
4393 : sig_i , & ! ice scattering coefficient (/m) ! LCOV_EXCL_LINE
4394 : sig_p , & ! pond scattering coefficient (/m) ! LCOV_EXCL_LINE
4395 : kext ! weighted extinction coefficient (/m)
4396 :
4397 : ! aerosol optical properties from Mark Flanner, 26 June 2008
4398 : ! order assumed: hydrophobic black carbon, hydrophilic black carbon,
4399 : ! four dust aerosols by particle size range:
4400 : ! dust1(.05-0.5 micron), dust2(0.5-1.25 micron),
4401 : ! dust3(1.25-2.5 micron), dust4(2.5-5.0 micron)
4402 : ! spectral bands same as snow/sea ice: (0.3-0.7 micron, 0.7-1.19 micron
4403 : ! and 1.19-5.0 micron in wavelength)
4404 :
4405 : integer (kind=int_kind) :: &
4406 : na , n ! aerosol index
4407 :
4408 : real (kind=dbl_kind) :: &
4409 : taer , & ! total aerosol extinction optical depth ! LCOV_EXCL_LINE
4410 : waer , & ! total aerosol single scatter albedo ! LCOV_EXCL_LINE
4411 : gaer , & ! total aerosol asymmetry parameter ! LCOV_EXCL_LINE
4412 : swdr , & ! shortwave down at surface, direct (W/m^2) ! LCOV_EXCL_LINE
4413 : swdf , & ! shortwave down at surface, diffuse (W/m^2) ! LCOV_EXCL_LINE
4414 : rnilyr , & ! 1/real(nilyr) ! LCOV_EXCL_LINE
4415 : rnslyr , & ! 1/real(nslyr) ! LCOV_EXCL_LINE
4416 : rns , & ! real(ns) ! LCOV_EXCL_LINE
4417 0 : tmp_0, tmp_ks, tmp_kl ! temporary variables
4418 :
4419 : integer(kind=int_kind), dimension(0:klev) :: &
4420 : k_bcini , & ! index ! LCOV_EXCL_LINE
4421 : k_bcins , & ! = 2 hardwired ! LCOV_EXCL_LINE
4422 0 : k_bcexs ! = 2 hardwired
4423 :
4424 : real(kind=dbl_kind):: &
4425 0 : tmp_gs, tmp1 ! temporary variables
4426 :
4427 : real (kind=dbl_kind), parameter :: &
4428 : fr_max = 1.00_dbl_kind, & ! snow grain adjustment factor max ! LCOV_EXCL_LINE
4429 : fr_min = 0.80_dbl_kind, & ! snow grain adjustment factor min ! LCOV_EXCL_LINE
4430 : ! tuning parameters
4431 : ! ice and pond scat coeff fractional change for +- one-sigma in albedo
4432 : fp_ice = 0.15_dbl_kind, & ! ice fraction of scat coeff for + stn dev in alb
4433 : fm_ice = 0.15_dbl_kind, & ! ice fraction of scat coeff for - stn dev in alb ! LCOV_EXCL_LINE
4434 : fp_pnd = 2.00_dbl_kind, & ! ponded ice fraction of scat coeff for + stn dev in alb ! LCOV_EXCL_LINE
4435 : fm_pnd = 0.50_dbl_kind ! ponded ice fraction of scat coeff for - stn dev in alb
4436 :
4437 : real (kind=dbl_kind), parameter :: & ! chla-specific absorption coefficient
4438 : kchl_tab = p01 ! 0.0023-0.0029 Perovich 1993, also 0.0067 m^2 (mg Chl)^-1
4439 : ! found values of 0.006 to 0.023 m^2/ mg (676 nm) Neukermans 2014
4440 : ! and averages over the 300-700nm of 0.0075 m^2/mg in ice Fritsen (2011)
4441 : ! at 440nm values as high as 0.2 m^2/mg in under ice bloom (Balch 2014)
4442 : ! Grenfell 1991 uses 0.004 (m^2/mg) which is (0.0078 * spectral weighting)
4443 : ! chlorophyll mass extinction cross section (m^2/mg chla)
4444 :
4445 : real (kind=dbl_kind), dimension (nspint_5bd) :: &
4446 : wghtns_5bd_dfs , & ! spectral weights for diffuse incident ! LCOV_EXCL_LINE
4447 0 : wghtns_5bd_drc ! spectral weights for direct incident
4448 :
4449 : ! snow grain single-scattering properties for
4450 : ! direct (drc) and diffuse (dfs) shortwave incidents
4451 : ! local variable names, point to table data
4452 : ! TODO use variable names in ice_shortwave_data directly
4453 : real (kind=dbl_kind), pointer, dimension(:,:) :: & ! Model SNICAR snow SSP
4454 : asm_prm_ice_drc , & ! snow asymmetry factor (cos(theta)) ! LCOV_EXCL_LINE
4455 : asm_prm_ice_dfs , & ! snow asymmetry factor (cos(theta)) ! LCOV_EXCL_LINE
4456 : ss_alb_ice_drc , & ! snow single scatter albedo (fraction) ! LCOV_EXCL_LINE
4457 : ss_alb_ice_dfs , & ! snow single scatter albedo (fraction) ! LCOV_EXCL_LINE
4458 : ext_cff_mss_ice_drc , & ! snow mass extinction cross section (m2/kg) ! LCOV_EXCL_LINE
4459 : ext_cff_mss_ice_dfs ! snow mass extinction cross section (m2/kg)
4460 :
4461 : ! FUTURE-WORK: update 5-band sea ice iops when avalible
4462 : real (kind=dbl_kind), dimension (nspint_5bd) :: & ! for ice only
4463 : ki_ssl_5bd , & ! Surface-scattering-layer ice extinction coefficient (/m) ! LCOV_EXCL_LINE
4464 : wi_ssl_5bd , & ! Surface-scattering-layer ice single scattering albedo ! LCOV_EXCL_LINE
4465 : gi_ssl_5bd , & ! Surface-scattering-layer ice asymmetry parameter ! LCOV_EXCL_LINE
4466 : ki_dl_5bd , & ! Drained-layer ice extinction coefficient (/m) ! LCOV_EXCL_LINE
4467 : wi_dl_5bd , & ! Drained-layer ice single scattering albedo ! LCOV_EXCL_LINE
4468 : gi_dl_5bd , & ! Drained-layer ice asymmetry parameter ! LCOV_EXCL_LINE
4469 : ki_int_5bd , & ! Interior-layer ice extinction coefficient (/m) ! LCOV_EXCL_LINE
4470 : wi_int_5bd , & ! Interior-layer ice single scattering albedo ! LCOV_EXCL_LINE
4471 0 : gi_int_5bd ! Interior-layer ice asymmetry parameter
4472 :
4473 : ! 5-band aersol data
4474 : real (kind=dbl_kind), dimension(nspint_5bd, 0:klev) :: &
4475 : kabs_chl_5bd , & ! absorption coefficient for chlorophyll (/m) ! LCOV_EXCL_LINE
4476 : tzaer_5bd , & ! total aerosol extinction optical depth ! LCOV_EXCL_LINE
4477 : wzaer_5bd , & ! total aerosol single scatter albedo ! LCOV_EXCL_LINE
4478 0 : gzaer_5bd ! total aerosol asymmetry parameter
4479 :
4480 : ! index
4481 : integer (kind=int_kind) :: &
4482 : nsky ! sky = 1 (2) for direct (diffuse) downward SW incident
4483 :
4484 : ! temporary variables used to assign variables for direct/diffuse incident
4485 : ! based on snicar 5 band IOPs
4486 : real (kind=dbl_kind), dimension (0:klevp) :: &
4487 : dfdir_snicar , & ! down-up flux at interface due to direct beam at top surface ! LCOV_EXCL_LINE
4488 : dfdif_snicar , & ! down-up flux at interface due to diffuse beam at top surface ! LCOV_EXCL_LINE
4489 : rupdir_snicar , & ! reflectivity to direct radiation for layers below ! LCOV_EXCL_LINE
4490 0 : rupdif_snicar ! reflectivity to diffuse radiation for layers above
4491 :
4492 : ! solar zenith angle parameters
4493 : real (kind=dbl_kind), parameter :: &
4494 : sza_a0 = 0.085730_dbl_kind , & ! LCOV_EXCL_LINE
4495 : sza_a1 = -0.630883_dbl_kind , & ! LCOV_EXCL_LINE
4496 : sza_a2 = 1.303723_dbl_kind , & ! LCOV_EXCL_LINE
4497 : sza_b0 = 1.467291_dbl_kind , & ! LCOV_EXCL_LINE
4498 : sza_b1 = -3.338043_dbl_kind , & ! LCOV_EXCL_LINE
4499 : sza_b2 = 6.807489_dbl_kind , & ! LCOV_EXCL_LINE
4500 : mu_75 = 0.2588_dbl_kind ! cos(75 degrees)
4501 :
4502 : real (kind=dbl_kind) :: &
4503 : sza_c1 , & ! parameter for high sza adjustment ! LCOV_EXCL_LINE
4504 : sza_c0 , & ! parameter for high sza adjustment ! LCOV_EXCL_LINE
4505 : sza_factor , & ! parameter for high sza adjustment ! LCOV_EXCL_LINE
4506 0 : mu0
4507 :
4508 : character(len=*),parameter :: subname='(compute_dEdd_5bd)'
4509 :
4510 : !-----------------------------------------------------------------------
4511 : ! Initialize and tune bare ice/ponded ice iops
4512 :
4513 : ! copy/point to table data for local names
4514 0 : asm_prm_ice_drc => ssp_sasymmdr
4515 0 : asm_prm_ice_dfs => ssp_sasymmdf
4516 0 : ss_alb_ice_drc => ssp_snwalbdr
4517 0 : ss_alb_ice_dfs => ssp_snwalbdf
4518 0 : ext_cff_mss_ice_drc => ssp_snwextdr
4519 0 : ext_cff_mss_ice_dfs => ssp_snwextdf
4520 :
4521 0 : k_bcini(:) = c0
4522 0 : k_bcins(:) = c0
4523 0 : k_bcexs(:) = c0
4524 :
4525 0 : rnilyr = c1/real(nilyr,kind=dbl_kind)
4526 0 : rnslyr = c1/real(nslyr,kind=dbl_kind)
4527 0 : kii = nslyr + 1
4528 :
4529 : ! initialize albedos and fluxes to 0
4530 0 : fthrul = c0
4531 0 : Iabs = c0
4532 0 : kabs_chl_5bd(:,:) = c0
4533 0 : tzaer_5bd (:,:) = c0
4534 0 : wzaer_5bd (:,:) = c0
4535 0 : gzaer_5bd (:,:) = c0
4536 :
4537 0 : avdr = c0
4538 0 : avdf = c0
4539 0 : aidr = c0
4540 0 : aidf = c0
4541 0 : fsfc = c0
4542 0 : fint = c0
4543 0 : fthru = c0
4544 0 : fthruvdr = c0
4545 0 : fthruvdf = c0
4546 0 : fthruidr = c0
4547 0 : fthruidf = c0
4548 :
4549 : ! spectral weights - 3 bands
4550 : ! this section of code is kept for future mearge between 5band and 3 band
4551 : ! subroutines
4552 : ! weights 2 (0.7-1.19 micro-meters) and 3 (1.19-5.0 micro-meters)
4553 : ! are chosen based on 1D calculations using ratio of direct to total
4554 : ! near-infrared solar (0.7-5.0 micro-meter) which indicates clear/cloudy
4555 : ! conditions: more cloud, the less 1.19-5.0 relative to the
4556 : ! 0.7-1.19 micro-meter due to cloud absorption.
4557 : ! wghtns(1) = c1
4558 : ! wghtns(2) = cp67 + (cp78-cp67)*(c1-fnidr)
4559 : ! wghtns(3) = cp33 + (cp22-cp33)*(c1-fnidr)
4560 : ! wghtns(3) = c1 - wghtns(2)
4561 :
4562 : ! spectral weights - 5 bands
4563 : ! direct beam incident
4564 : ! add-local-variable
4565 0 : wghtns_5bd_drc(1) = c1
4566 0 : wghtns_5bd_drc(2) = 0.49352158521175_dbl_kind
4567 0 : wghtns_5bd_drc(3) = 0.18099494230665_dbl_kind
4568 0 : wghtns_5bd_drc(4) = 0.12094898498813_dbl_kind
4569 0 : wghtns_5bd_drc(5) = c1-(wghtns_5bd_drc(2)+wghtns_5bd_drc(3)+wghtns_5bd_drc(4))
4570 :
4571 : ! diffuse incident
4572 0 : wghtns_5bd_dfs(1) = c1
4573 0 : wghtns_5bd_dfs(2) = 0.58581507618433_dbl_kind
4574 0 : wghtns_5bd_dfs(3) = 0.20156903770812_dbl_kind
4575 0 : wghtns_5bd_dfs(4) = 0.10917889346386_dbl_kind
4576 0 : wghtns_5bd_dfs(5) = c1-(wghtns_5bd_dfs(2)+wghtns_5bd_dfs(3)+wghtns_5bd_dfs(4))
4577 :
4578 0 : do k = 1, nslyr
4579 : !frsnw(k) = (fr_max*fnidr + fr_min*(c1-fnidr))*rsnw(k)
4580 0 : Sabs(k) = c0
4581 : enddo
4582 :
4583 : ! layer thicknesses
4584 : ! snow
4585 0 : dz = hs*rnslyr
4586 : ! for small enough snow thickness, ssl thickness half of top snow layer
4587 : !ech: note this is highly resolution dependent!
4588 0 : dzk(0) = min(hs_ssl, dz/c2)
4589 0 : dzk(1) = dz - dzk(0)
4590 0 : if (nslyr > 1) then
4591 0 : do k = 2, nslyr
4592 0 : dzk(k) = dz
4593 : enddo
4594 : endif
4595 :
4596 : ! ice
4597 0 : dz = hi*rnilyr
4598 : ! empirical reduction in sea ice ssl thickness for ice thinner than 1.5m;
4599 : ! factor of 30 gives best albedo comparison with limited observations
4600 0 : dz_ssl = hi_ssl
4601 : !ech: note hardwired parameters
4602 : ! if( hi < 1.5_dbl_kind ) dz_ssl = hi/30._dbl_kind
4603 0 : dz_ssl = min(hi_ssl, hi/30._dbl_kind)
4604 : ! set sea ice ssl thickness to half top layer if sea ice thin enough
4605 : !ech: note this is highly resolution dependent!
4606 0 : dz_ssl = min(dz_ssl, dz/c2)
4607 :
4608 0 : dzk(kii) = dz_ssl
4609 0 : dzk(kii+1) = dz - dz_ssl
4610 0 : if (kii+2 <= klev) then
4611 0 : do k = kii+2, klev
4612 0 : dzk(k) = dz
4613 : enddo
4614 : endif
4615 :
4616 : ! adjust sea ice iops with tuning parameters; tune only the
4617 : ! scattering coefficient by factors of R_ice, R_pnd, where
4618 : ! R values of +1 correspond approximately to +1 sigma changes in albedo, and
4619 : ! R values of -1 correspond approximately to -1 sigma changes in albedo
4620 : ! Note: the albedo change becomes non-linear for R values > +1 or < -1
4621 0 : if( R_ice >= c0 ) then
4622 0 : do ns = 1, nspint_5bd
4623 0 : sigp = ki_ssl_mn_5bd(ns)*wi_ssl_mn_5bd(ns)*(c1+fp_ice*R_ice)
4624 0 : ki_ssl_5bd(ns) = sigp+ki_ssl_mn_5bd(ns)*(c1-wi_ssl_mn_5bd(ns))
4625 0 : wi_ssl_5bd(ns) = sigp/ki_ssl_5bd(ns)
4626 0 : gi_ssl_5bd(ns) = gi_ssl_mn_5bd(ns)
4627 :
4628 0 : sigp = ki_dl_mn_5bd(ns)*wi_dl_mn_5bd(ns)*(c1+fp_ice*R_ice)
4629 0 : ki_dl_5bd(ns) = sigp+ki_dl_mn_5bd(ns)*(c1-wi_dl_mn_5bd(ns))
4630 0 : wi_dl_5bd(ns) = sigp/ki_dl_5bd(ns)
4631 0 : gi_dl_5bd(ns) = gi_dl_mn_5bd(ns)
4632 :
4633 0 : sigp = ki_int_mn_5bd(ns)*wi_int_mn_5bd(ns)*(c1+fp_ice*R_ice)
4634 0 : ki_int_5bd(ns) = sigp+ki_int_mn_5bd(ns)*(c1-wi_int_mn_5bd(ns))
4635 0 : wi_int_5bd(ns) = sigp/ki_int_5bd(ns)
4636 0 : gi_int_5bd(ns) = gi_int_mn_5bd(ns)
4637 : enddo
4638 : else !if( R_ice < c0 ) then
4639 0 : do ns = 1, nspint_5bd
4640 0 : sigp = ki_ssl_mn_5bd(ns)*wi_ssl_mn_5bd(ns)*(c1+fm_ice*R_ice)
4641 0 : sigp = max(sigp, c0)
4642 0 : ki_ssl_5bd(ns) = sigp+ki_ssl_mn_5bd(ns)*(c1-wi_ssl_mn_5bd(ns))
4643 0 : wi_ssl_5bd(ns) = sigp/ki_ssl_5bd(ns)
4644 0 : gi_ssl_5bd(ns) = gi_ssl_mn_5bd(ns)
4645 :
4646 0 : sigp = ki_dl_mn_5bd(ns)*wi_dl_mn_5bd(ns)*(c1+fm_ice*R_ice)
4647 0 : sigp = max(sigp, c0)
4648 0 : ki_dl_5bd(ns) = sigp+ki_dl_mn_5bd(ns)*(c1-wi_dl_mn_5bd(ns))
4649 0 : wi_dl_5bd(ns) = sigp/ki_dl_5bd(ns)
4650 0 : gi_dl_5bd(ns) = gi_dl_mn_5bd(ns)
4651 :
4652 0 : sigp = ki_int_mn_5bd(ns)*wi_int_mn_5bd(ns)*(c1+fm_ice*R_ice)
4653 0 : sigp = max(sigp, c0)
4654 0 : ki_int_5bd(ns) = sigp+ki_int_mn_5bd(ns)*(c1-wi_int_mn_5bd(ns))
4655 0 : wi_int_5bd(ns) = sigp/ki_int_5bd(ns)
4656 0 : gi_int_5bd(ns) = gi_int_mn_5bd(ns)
4657 : enddo
4658 : endif ! adjust ice iops
4659 :
4660 : ! use srftyp to determine interface index of surface absorption
4661 0 : ksrf = 1 ! snow covered sea ice
4662 :
4663 0 : if (tr_bgc_N .and. dEdd_algae) then ! compute kabs_chl for chlorophyll
4664 0 : do k = 0, klev
4665 0 : kabs_chl_5bd(1,k) = kchl_tab*zbio(nlt_chl_sw+k)
4666 : enddo
4667 : else
4668 0 : k = klev
4669 0 : kabs_chl_5bd(1,k) = kalg*(0.50_dbl_kind/dzk(k))
4670 : endif
4671 :
4672 0 : if (modal_aero) then
4673 0 : do k = 0, klev
4674 0 : if (k < nslyr+1) then ! define indices for snow layer
4675 : ! use top rsnw, rhosnw for snow ssl and rest of top layer
4676 : ! Cheng: note that aerosol IOPs are related to snow grain radius.
4677 : ! CICE adjusted snow grain radius rsnw to frsnw, while for
4678 : ! SNICAR there is no need, the tmp_gs is therefore calculated
4679 : ! differently from code in subroutine compute_dEdd
4680 0 : ksnow = k - min(k-1,0)
4681 0 : tmp_gs = rsnw(ksnow) ! use rsnw not frsnw
4682 :
4683 : ! grain size index
4684 : ! works for 25 < snw_rds < 1625 um:
4685 0 : if (tmp_gs < 125._dbl_kind) then
4686 0 : tmp1 = tmp_gs/50._dbl_kind
4687 0 : k_bcini(k) = nint(tmp1)
4688 0 : elseif (tmp_gs < 175._dbl_kind) then
4689 0 : k_bcini(k) = 2
4690 : else
4691 0 : tmp1 = (tmp_gs/250._dbl_kind) + c2
4692 0 : k_bcini(k) = nint(tmp1)
4693 : endif
4694 : else ! use the largest snow grain size for ice
4695 0 : k_bcini(k) = 8
4696 : endif
4697 : ! Set index corresponding to BC effective radius. Here,
4698 : ! asssume constant BC effective radius of 100nm
4699 : ! (corresponding to index 2)
4700 0 : k_bcins(k) = 2 ! hardwired
4701 0 : k_bcexs(k) = 2 ! hardwired
4702 :
4703 : ! check bounds
4704 0 : if (k_bcini(k) < 1) k_bcini(k) = 1
4705 0 : if (k_bcini(k) > 8) k_bcini(k) = 8
4706 : ! if (k_bcins(k) < 1) k_bcins(k) = 1 ! hardwired
4707 : ! if (k_bcins(k) > 10) k_bcins(k) = 10
4708 : ! if (k_bcexs(k) < 1) k_bcexs(k) = 1
4709 : ! if (k_bcexs(k) > 10) k_bcexs(k) = 10
4710 : enddo ! k
4711 :
4712 0 : if (tr_zaero .and. dEdd_algae) then ! compute kzaero for chlorophyll
4713 0 : do n = 1, n_zaero
4714 0 : if (n == 1) then ! interstitial BC
4715 0 : do k = 0, klev
4716 0 : do ns = 1, nspint_5bd ! not weighted by aice
4717 0 : tzaer_5bd(ns,k) = tzaer_5bd (ns,k) &
4718 : + kaer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
4719 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4720 0 : wzaer_5bd(ns,k) = wzaer_5bd (ns,k) &
4721 : + kaer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
4722 : * waer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
4723 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4724 0 : gzaer_5bd(ns,k) = gzaer_5bd (ns,k) &
4725 : + kaer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
4726 : * waer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
4727 : * gaer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
4728 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4729 : enddo
4730 : enddo
4731 0 : elseif (n==2) then ! within-ice BC
4732 0 : do k = 0, klev
4733 0 : do ns = 1, nspint_5bd
4734 0 : tzaer_5bd(ns,k) = tzaer_5bd (ns,k) &
4735 : + kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4736 : * bcenh_5bd(ns,k_bcins(k),k_bcini(k)) & ! LCOV_EXCL_LINE
4737 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4738 0 : wzaer_5bd(ns,k) = wzaer_5bd (ns,k) &
4739 : + kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4740 : * waer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4741 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4742 0 : gzaer_5bd(ns,k) = gzaer_5bd (ns,k) &
4743 : + kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4744 : * waer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4745 : * gaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4746 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4747 : enddo
4748 : enddo
4749 : else ! dust
4750 0 : do k = 0, klev
4751 0 : do ns = 1, nspint_5bd ! not weighted by aice
4752 0 : tzaer_5bd(ns,k) = tzaer_5bd(ns,k) &
4753 : + kaer_5bd (ns,n) & ! LCOV_EXCL_LINE
4754 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4755 0 : wzaer_5bd(ns,k) = wzaer_5bd(ns,k) &
4756 : + kaer_5bd (ns,n) & ! LCOV_EXCL_LINE
4757 : * waer_5bd (ns,n) & ! LCOV_EXCL_LINE
4758 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4759 0 : gzaer_5bd(ns,k) = gzaer_5bd(ns,k) &
4760 : + kaer_5bd (ns,n) & ! LCOV_EXCL_LINE
4761 : * waer_5bd (ns,n) & ! LCOV_EXCL_LINE
4762 : * gaer_5bd (ns,n) & ! LCOV_EXCL_LINE
4763 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4764 : enddo ! nspint
4765 : enddo ! k
4766 : endif ! n
4767 : enddo ! n_zaero
4768 : endif ! tr_zaero and dEdd_algae
4769 :
4770 : else ! Bulk aerosol treatment
4771 0 : if (tr_zaero .and. dEdd_algae) then ! compute kzaero for chlorophyll
4772 0 : do n = 1, n_zaero ! multiply by aice?
4773 0 : do k = 0, klev
4774 0 : do ns = 1, nspint_5bd ! not weighted by aice
4775 0 : tzaer_5bd(ns,k) = tzaer_5bd(ns,k) &
4776 : + kaer_5bd (ns,n) & ! LCOV_EXCL_LINE
4777 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4778 0 : wzaer_5bd(ns,k) = wzaer_5bd(ns,k) &
4779 : + kaer_5bd (ns,n) & ! LCOV_EXCL_LINE
4780 : * waer_5bd (ns,n) & ! LCOV_EXCL_LINE
4781 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4782 0 : gzaer_5bd(ns,k) = gzaer_5bd(ns,k) &
4783 : + kaer_5bd (ns,n) & ! LCOV_EXCL_LINE
4784 : * waer_5bd (ns,n) & ! LCOV_EXCL_LINE
4785 : * gaer_5bd (ns,n) & ! LCOV_EXCL_LINE
4786 0 : * zbio(nlt_zaero_sw(n)+k) * dzk(k)
4787 : enddo ! nspint
4788 : enddo ! k
4789 : enddo ! n
4790 : endif ! tr_zaero
4791 : endif ! modal_aero
4792 :
4793 : !-----------------------------------------------------------------------
4794 :
4795 : ! begin spectral loop
4796 0 : do ns = 1, nspint_5bd
4797 :
4798 : ! for snow-covered sea ice, compute 5 bands
4799 : !if( srftyp == 1 ) then
4800 : ! SNICAR-AD major changes
4801 : ! 1. loop through 5bands: do ns = 1, nspint_5bd based on nsky
4802 : ! 2. use snow grain size rsnow, not scaled frsnw
4803 : ! 3. replace $IOPs_tab with $IOPs_snicar
4804 : ! 4. replace wghtns with wghtns_5bd
4805 0 : do nsky = 1, 2 ! loop for both direct beam and diffuse beam
4806 0 : if (nsky == 1) then ! direct incident
4807 0 : do k = 0, nslyr
4808 : ! use top rsnw, rhosnw for snow ssl and rest of top layer
4809 0 : ksnow = k - min(k-1,0)
4810 0 : if (rsnw(ksnow) <= rsnw_snicar_min) then
4811 0 : ks = ext_cff_mss_ice_drc(ns,1)
4812 0 : ws = ss_alb_ice_drc (ns,1)
4813 0 : gs = asm_prm_ice_drc (ns,1)
4814 0 : elseif (rsnw(ksnow) >= rsnw_snicar_max) then
4815 0 : ks = ext_cff_mss_ice_drc(ns,nmbrad_snicar)
4816 0 : ws = ss_alb_ice_drc (ns,nmbrad_snicar)
4817 0 : gs = asm_prm_ice_drc (ns,nmbrad_snicar)
4818 0 : elseif (ceiling(rsnw(ksnow)) - rsnw(ksnow) < 1.0e-3_dbl_kind) then
4819 : ! radius = 30 --> nr = 1 in SNICAR table ! NOTE
4820 0 : nr = ceiling(rsnw(ksnow)) - 30 + 1 ! hardwired min radius = 30
4821 0 : ks = ext_cff_mss_ice_drc(ns,nr)
4822 0 : ws = ss_alb_ice_drc (ns,nr)
4823 0 : gs = asm_prm_ice_drc (ns,nr)
4824 : else ! linear interpolation in rsnw
4825 0 : nr = ceiling(rsnw(ksnow)) - 30 + 1 ! hardwired min radius = 30
4826 0 : delr = (rsnw(ksnow) - floor(rsnw(ksnow))) & ! hardwired delta radius = 1 in table
4827 0 : / (ceiling(rsnw(ksnow)) - floor(rsnw(ksnow))) ! denom always = 1
4828 0 : ks = ext_cff_mss_ice_drc(ns,nr-1)*(c1-delr) &
4829 0 : + ext_cff_mss_ice_drc(ns,nr )* delr
4830 0 : ws = ss_alb_ice_drc (ns,nr-1)*(c1-delr) &
4831 0 : + ss_alb_ice_drc (ns,nr )* delr
4832 0 : gs = asm_prm_ice_drc (ns,nr-1)*(c1-delr) &
4833 0 : + asm_prm_ice_drc (ns,nr )* delr
4834 : endif
4835 0 : tau(k) = (ks*rhosnw(ksnow) + kabs_chl_5bd(ns,k))*dzk(k)
4836 0 : w0 (k) = ks*rhosnw(ksnow) / (ks*rhosnw(ksnow) + kabs_chl_5bd(ns,k)) * ws
4837 0 : g (k) = gs
4838 : enddo ! k
4839 0 : elseif (nsky == 2) then ! diffuse incident
4840 0 : do k = 0, nslyr
4841 : ! use top rsnw, rhosnw for snow ssl and rest of top layer
4842 0 : ksnow = k - min(k-1,0)
4843 0 : if (rsnw(ksnow) < rsnw_snicar_min) then
4844 0 : ks = ext_cff_mss_ice_dfs(ns,1)
4845 0 : ws = ss_alb_ice_dfs (ns,1)
4846 0 : gs = asm_prm_ice_dfs (ns,1)
4847 0 : elseif (rsnw(ksnow) > rsnw_snicar_max) then
4848 0 : ks = ext_cff_mss_ice_dfs(ns,nmbrad_snicar)
4849 0 : ws = ss_alb_ice_dfs (ns,nmbrad_snicar)
4850 0 : gs = asm_prm_ice_dfs (ns,nmbrad_snicar)
4851 0 : elseif (ceiling(rsnw(ksnow)) - rsnw(ksnow) < 1.0e-3_dbl_kind) then
4852 : ! radius = 30 --> nr = 1 in SNICAR table ! NOTE
4853 0 : nr = ceiling(rsnw(ksnow)) - 30 + 1 ! hardwired min radius = 30
4854 0 : ks = ext_cff_mss_ice_dfs(ns,nr)
4855 0 : ws = ss_alb_ice_dfs (ns,nr)
4856 0 : gs = asm_prm_ice_dfs (ns,nr)
4857 : else ! linear interpolation in rsnw
4858 0 : nr = ceiling(rsnw(ksnow)) - 30 + 1 ! hardwired min radius = 30
4859 0 : delr = (rsnw(ksnow) - floor(rsnw(ksnow))) & ! hardwired delta radius = 1 in table
4860 0 : / (ceiling(rsnw(ksnow)) - floor(rsnw(ksnow)))
4861 0 : ks = ext_cff_mss_ice_dfs(ns,nr-1)*(c1-delr) &
4862 0 : + ext_cff_mss_ice_dfs(ns,nr )* delr
4863 0 : ws = ss_alb_ice_dfs (ns,nr-1)*(c1-delr) &
4864 0 : + ss_alb_ice_dfs (ns,nr )* delr
4865 0 : gs = asm_prm_ice_dfs (ns,nr-1)*(c1-delr) &
4866 0 : + asm_prm_ice_dfs (ns,nr )* delr
4867 : endif
4868 0 : tau(k) = (ks*rhosnw(ksnow) + kabs_chl_5bd(ns,k))*dzk(k)
4869 0 : w0 (k) = ks*rhosnw(ksnow) / (ks*rhosnw(ksnow) + kabs_chl_5bd(ns,k)) * ws
4870 0 : g (k) = gs
4871 : enddo ! k
4872 : endif ! nsky for snow IOPs
4873 :
4874 : !------------------------------------------------------------------------------
4875 :
4876 : ! aerosol in snow
4877 0 : if (tr_zaero .and. dEdd_algae) then
4878 0 : do k = 0,nslyr
4879 0 : g (k) = (g(k)*w0(k)*tau(k) + gzaer_5bd(ns,k)) / &
4880 0 : (w0(k)*tau(k) + wzaer_5bd(ns,k))
4881 0 : w0 (k) = (w0(k)*tau(k) + wzaer_5bd(ns,k)) / &
4882 0 : (tau(k) + tzaer_5bd(ns,k))
4883 0 : tau(k) = tau(k) + tzaer_5bd(ns,k)
4884 : enddo
4885 0 : elseif (tr_aero) then
4886 0 : k = 0 ! snow SSL
4887 0 : taer = c0
4888 0 : waer = c0
4889 0 : gaer = c0
4890 :
4891 0 : do na = 1, 4*n_aero, 4
4892 0 : if (modal_aero) then
4893 0 : if (na == 1) then ! interstitial BC
4894 0 : taer = taer + aero_mp(na)*kaer_bc_5bd(ns,k_bcexs(k))
4895 0 : waer = waer + aero_mp(na)*kaer_bc_5bd(ns,k_bcexs(k)) &
4896 0 : *waer_bc_5bd(ns,k_bcexs(k))
4897 0 : gaer = gaer + aero_mp(na)*kaer_bc_5bd(ns,k_bcexs(k)) &
4898 : *waer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
4899 0 : *gaer_bc_5bd(ns,k_bcexs(k))
4900 0 : elseif (na == 5) then ! within-ice BC
4901 0 : taer = taer + aero_mp(na)*kaer_bc_5bd(ns,k_bcins(k)) &
4902 0 : * bcenh_5bd(ns,k_bcins(k),k_bcini(k))
4903 0 : waer = waer + aero_mp(na)*kaer_bc_5bd(ns,k_bcins(k)) &
4904 0 : *waer_bc_5bd(ns,k_bcins(k))
4905 0 : gaer = gaer + aero_mp(na)*kaer_bc_5bd(ns,k_bcins(k)) &
4906 : *waer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4907 0 : *gaer_bc_5bd(ns,k_bcins(k))
4908 : else ! other species (dust)
4909 0 : taer = taer + aero_mp(na)*kaer_5bd(ns,(1+(na-1)/4))
4910 0 : waer = waer + aero_mp(na)*kaer_5bd(ns,(1+(na-1)/4)) &
4911 0 : *waer_5bd(ns,(1+(na-1)/4))
4912 0 : gaer = gaer + aero_mp(na)*kaer_5bd(ns,(1+(na-1)/4)) &
4913 : *waer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
4914 0 : *gaer_5bd(ns,(1+(na-1)/4))
4915 : endif
4916 : else
4917 0 : taer = taer + aero_mp(na)*kaer_5bd(ns,(1+(na-1)/4))
4918 0 : waer = waer + aero_mp(na)*kaer_5bd(ns,(1+(na-1)/4)) &
4919 0 : *waer_5bd(ns,(1+(na-1)/4))
4920 0 : gaer = gaer + aero_mp(na)*kaer_5bd(ns,(1+(na-1)/4)) &
4921 : *waer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
4922 0 : *gaer_5bd(ns,(1+(na-1)/4))
4923 : endif ! modal_aero
4924 : enddo ! na
4925 0 : g (k) = (g(k)*w0(k)*tau(k) + gaer) / &
4926 0 : (w0(k)*tau(k) + waer)
4927 0 : w0 (k) = (w0(k)*tau(k) + waer) / &
4928 0 : (tau(k) + taer)
4929 0 : tau(k) = tau(k) + taer
4930 :
4931 0 : do k = 1, nslyr
4932 0 : taer = c0
4933 0 : waer = c0
4934 0 : gaer = c0
4935 0 : do na = 1, 4*n_aero, 4
4936 0 : if (modal_aero) then
4937 0 : if (na==1) then ! interstitial BC
4938 0 : taer = taer + (aero_mp(na+1)*rnslyr) &
4939 0 : * kaer_bc_5bd(ns,k_bcexs(k))
4940 0 : waer = waer + (aero_mp(na+1)*rnslyr) &
4941 : * kaer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
4942 0 : * waer_bc_5bd(ns,k_bcexs(k))
4943 0 : gaer = gaer + (aero_mp(na+1)*rnslyr) &
4944 : * kaer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
4945 : * waer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
4946 0 : * gaer_bc_5bd(ns,k_bcexs(k))
4947 0 : elseif (na==5) then ! within-ice BC
4948 0 : taer = taer + (aero_mp(na+1)*rnslyr) &
4949 : * kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4950 0 : * bcenh_5bd(ns,k_bcins(k),k_bcini(k))
4951 0 : waer = waer + (aero_mp(na+1)*rnslyr) &
4952 : * kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4953 0 : * waer_bc_5bd(ns,k_bcins(k))
4954 0 : gaer = gaer + (aero_mp(na+1)*rnslyr) &
4955 : * kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4956 : * waer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
4957 0 : * gaer_bc_5bd(ns,k_bcins(k))
4958 : else ! other species (dust)
4959 0 : taer = taer + (aero_mp(na+1)*rnslyr) &
4960 0 : * kaer_5bd(ns,(1+(na-1)/4))
4961 0 : waer = waer + (aero_mp(na+1)*rnslyr) &
4962 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
4963 0 : * waer_5bd(ns,(1+(na-1)/4))
4964 0 : gaer = gaer + (aero_mp(na+1)*rnslyr) &
4965 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
4966 : * waer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
4967 0 : * gaer_5bd(ns,(1+(na-1)/4))
4968 : endif ! na
4969 : else
4970 0 : taer = taer + (aero_mp(na+1)*rnslyr) &
4971 0 : * kaer_5bd(ns,(1+(na-1)/4))
4972 0 : waer = waer + (aero_mp(na+1)*rnslyr) &
4973 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
4974 0 : * waer_5bd(ns,(1+(na-1)/4))
4975 0 : gaer = gaer + (aero_mp(na+1)*rnslyr) &
4976 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
4977 : * waer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
4978 0 : * gaer_5bd(ns,(1+(na-1)/4))
4979 : endif ! modal_aero
4980 : enddo ! na
4981 0 : g (k) = (g(k)*w0(k)*tau(k) + gaer) / &
4982 0 : (w0(k)*tau(k) + waer)
4983 0 : w0 (k) = (w0(k)*tau(k) + waer) / &
4984 0 : (tau(k) + taer)
4985 0 : tau(k) = tau(k) + taer
4986 : enddo ! k
4987 : endif ! tr_aero
4988 :
4989 : ! set optical properties of sea ice
4990 :
4991 : ! bare or snow-covered sea ice layers
4992 : !if (srftyp <= 1) then
4993 : ! ssl
4994 0 : k = kii
4995 0 : tau(k) = (ki_ssl_5bd(ns) + kabs_chl_5bd(ns,k)) * dzk(k)
4996 0 : w0 (k) = ki_ssl_5bd(ns)/(ki_ssl_5bd(ns) + kabs_chl_5bd(ns,k)) * wi_ssl_5bd(ns)
4997 0 : g (k) = gi_ssl_5bd(ns)
4998 : ! dl
4999 0 : k = kii + 1
5000 : ! scale dz for dl relative to 4 even-layer-thickness 1.5m case
5001 0 : fs = p25*real(nilyr,kind=dbl_kind)
5002 0 : tau(k) = (ki_dl_5bd(ns) + kabs_chl_5bd(ns,k)) * dzk(k) * fs
5003 0 : w0 (k) = ki_dl_5bd(ns)/(ki_dl_5bd(ns) + kabs_chl_5bd(ns,k)) * wi_dl_5bd(ns)
5004 0 : g (k) = gi_dl_5bd(ns)
5005 : ! int above lowest layer
5006 0 : if (kii+2 <= klev-1) then
5007 0 : do k = kii+2, klev-1
5008 0 : tau(k) = (ki_int_5bd(ns) + kabs_chl_5bd(ns,k)) * dzk(k)
5009 0 : w0 (k) = ki_int_5bd(ns)/(ki_int_5bd(ns) + kabs_chl_5bd(ns,k)) * wi_int_5bd(ns)
5010 0 : g (k) = gi_int_5bd(ns)
5011 : enddo
5012 : endif
5013 : ! lowest layer
5014 0 : k = klev
5015 : ! add algae to lowest sea ice layer, visible only:
5016 0 : kabs = ki_int_5bd(ns)*(c1-wi_int_5bd(ns))
5017 0 : if (ns == 1) then
5018 : ! total layer absorption optical depth fixed at value
5019 : ! of kalg*0.50m, independent of actual layer thickness
5020 0 : kabs = kabs + kabs_chl_5bd(ns,k)
5021 : endif
5022 0 : sig = ki_int_5bd(ns)*wi_int_5bd(ns)
5023 0 : tau(k) = (kabs+sig) * dzk(k)
5024 0 : w0 (k) = sig/(sig+kabs)
5025 0 : g (k) = gi_int_5bd(ns)
5026 : ! aerosol in sea ice
5027 0 : if (tr_zaero .and. dEdd_algae) then
5028 0 : do k = kii, klev
5029 0 : g (k) = (g(k)*w0(k)*tau(k) + gzaer_5bd(ns,k)) / &
5030 0 : (w0(k)*tau(k) + wzaer_5bd(ns,k))
5031 0 : w0 (k) = (w0(k)*tau(k) + wzaer_5bd(ns,k)) / &
5032 0 : (tau(k) + tzaer_5bd(ns,k))
5033 0 : tau(k) = tau(k) + tzaer_5bd(ns,k)
5034 : enddo
5035 0 : elseif (tr_aero) then
5036 0 : k = kii ! sea ice SSL
5037 0 : taer = c0
5038 0 : waer = c0
5039 0 : gaer = c0
5040 0 : do na = 1, 4*n_aero, 4
5041 0 : if (modal_aero) then
5042 0 : if (na==1) then ! interstitial BC
5043 0 : taer = taer + aero_mp(na+2) &
5044 0 : * kaer_bc_5bd(ns,k_bcexs(k))
5045 0 : waer = waer + aero_mp(na+2) &
5046 : * kaer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
5047 0 : * waer_bc_5bd(ns,k_bcexs(k))
5048 0 : gaer = gaer + aero_mp(na+2) &
5049 : * kaer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
5050 : * waer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
5051 0 : * gaer_bc_5bd(ns,k_bcexs(k))
5052 0 : elseif (na==5) then ! within-ice BC
5053 0 : taer = taer + aero_mp(na+2) &
5054 : * kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
5055 0 : * bcenh_5bd(ns,k_bcins(k),k_bcini(k))
5056 0 : waer = waer + aero_mp(na+2) &
5057 : * kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
5058 0 : * waer_bc_5bd(ns,k_bcins(k))
5059 0 : gaer = gaer + aero_mp(na+2) &
5060 : * kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
5061 : * waer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
5062 0 : * gaer_bc_5bd(ns,k_bcins(k))
5063 : else ! other species (dust)
5064 0 : taer = taer + aero_mp(na+2) &
5065 0 : * kaer_5bd(ns,(1+(na-1)/4))
5066 0 : waer = waer + aero_mp(na+2) &
5067 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5068 0 : * waer_5bd(ns,(1+(na-1)/4))
5069 0 : gaer = gaer + aero_mp(na+2) &
5070 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5071 : * waer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5072 0 : * gaer_5bd(ns,(1+(na-1)/4))
5073 : endif
5074 : else ! bulk
5075 0 : taer = taer + aero_mp(na+2) &
5076 0 : * kaer_5bd(ns,(1+(na-1)/4))
5077 0 : waer = waer + aero_mp(na+2) &
5078 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5079 0 : * waer_5bd(ns,(1+(na-1)/4))
5080 0 : gaer = gaer + aero_mp(na+2) &
5081 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5082 : * waer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5083 0 : * gaer_5bd(ns,(1+(na-1)/4))
5084 : endif ! modal_aero
5085 : enddo ! na
5086 0 : g (k) = (g(k)*w0(k)*tau(k) + gaer) / &
5087 0 : (w0(k)*tau(k) + waer)
5088 0 : w0 (k) = (w0(k)*tau(k) + waer) / &
5089 0 : (tau(k) + taer)
5090 0 : tau(k) = tau(k) + taer
5091 0 : do k = kii+1, klev
5092 0 : taer = c0
5093 0 : waer = c0
5094 0 : gaer = c0
5095 0 : do na = 1, 4*n_aero, 4
5096 0 : if (modal_aero) then
5097 0 : if (na==1) then ! interstitial BC
5098 0 : taer = taer + (aero_mp(na+3)*rnilyr) &
5099 0 : * kaer_bc_5bd(ns,k_bcexs(k))
5100 0 : waer = waer + (aero_mp(na+3)*rnilyr) &
5101 : * kaer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
5102 0 : * waer_bc_5bd(ns,k_bcexs(k))
5103 0 : gaer = gaer + (aero_mp(na+3)*rnilyr) &
5104 : * kaer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
5105 : * waer_bc_5bd(ns,k_bcexs(k)) & ! LCOV_EXCL_LINE
5106 0 : * gaer_bc_5bd(ns,k_bcexs(k))
5107 0 : elseif (na==5) then ! within-ice BC
5108 0 : taer = taer + (aero_mp(na+3)*rnilyr) &
5109 : * kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
5110 0 : * bcenh_5bd(ns,k_bcins(k),k_bcini(k))
5111 0 : waer = waer + (aero_mp(na+3)*rnilyr) &
5112 : * kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
5113 0 : * waer_bc_5bd(ns,k_bcins(k))
5114 0 : gaer = gaer + (aero_mp(na+3)*rnilyr) &
5115 : * kaer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
5116 : * waer_bc_5bd(ns,k_bcins(k)) & ! LCOV_EXCL_LINE
5117 0 : * gaer_bc_5bd(ns,k_bcins(k))
5118 : else ! other species (dust)
5119 0 : taer = taer + (aero_mp(na+3)*rnilyr) &
5120 0 : * kaer_5bd(ns,(1+(na-1)/4))
5121 0 : waer = waer + (aero_mp(na+3)*rnilyr) &
5122 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5123 0 : * waer_5bd(ns,(1+(na-1)/4))
5124 0 : gaer = gaer + (aero_mp(na+3)*rnilyr) &
5125 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5126 : * waer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5127 0 : * gaer_5bd(ns,(1+(na-1)/4))
5128 : endif
5129 : else !bulk
5130 0 : taer = taer + (aero_mp(na+3)*rnilyr) &
5131 0 : * kaer_5bd(ns,(1+(na-1)/4))
5132 0 : waer = waer + (aero_mp(na+3)*rnilyr) &
5133 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5134 0 : * waer_5bd(ns,(1+(na-1)/4))
5135 0 : gaer = gaer + (aero_mp(na+3)*rnilyr) &
5136 : * kaer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5137 : * waer_5bd(ns,(1+(na-1)/4)) & ! LCOV_EXCL_LINE
5138 0 : * gaer_5bd(ns,(1+(na-1)/4))
5139 : endif ! modal_aero
5140 : enddo ! na
5141 0 : g (k) = (g(k)*w0(k)*tau(k) + gaer) / &
5142 0 : (w0(k)*tau(k) + waer)
5143 0 : w0 (k) = (w0(k)*tau(k) + waer) / &
5144 0 : (tau(k) + taer)
5145 0 : tau(k) = tau(k) + taer
5146 : enddo ! k
5147 : endif ! tr_aero
5148 :
5149 : ! ---------------------------------------------------------------------------
5150 :
5151 : ! set reflectivities for ocean underlying sea ice
5152 : ! if ns == 1 (visible), albedo is 0.1, else, albedo is zero
5153 0 : rns = real(ns-1, kind=dbl_kind)
5154 0 : albodr = cp01 * (c1 - min(rns, c1))
5155 0 : albodf = cp01 * (c1 - min(rns, c1))
5156 :
5157 : ! layer input properties now completely specified: tau, w0, g,
5158 : ! albodr, albodf; now compute the Delta-Eddington solution
5159 : ! reflectivities and transmissivities for each layer; then,
5160 : ! combine the layers going downwards accounting for multiple
5161 : ! scattering between layers, and finally start from the
5162 : ! underlying ocean and combine successive layers upwards to
5163 : ! the surface; see comments in solution_dEdd for more details.
5164 :
5165 : call solution_dEdd ( &
5166 : coszen, srftyp, klev, klevp, & ! LCOV_EXCL_LINE
5167 : tau, w0, g, albodr, albodf, & ! LCOV_EXCL_LINE
5168 : trndir, trntdr, trndif, rupdir, rupdif, & ! LCOV_EXCL_LINE
5169 0 : rdndif)
5170 0 : if (icepack_warnings_aborted(subname)) return
5171 :
5172 : ! the interface reflectivities and transmissivities required
5173 : ! to evaluate interface fluxes are returned from solution_dEdd;
5174 : ! now compute up and down fluxes for each interface, using the
5175 : ! combined layer properties at each interface:
5176 : !
5177 : ! layers interface
5178 : !
5179 : ! --------------------- k
5180 : ! k
5181 : ! ---------------------
5182 :
5183 0 : do k = 0, klevp
5184 : ! interface scattering
5185 0 : refk = c1/(c1 - rdndif(k)*rupdif(k))
5186 : ! dir tran ref from below times interface scattering, plus diff
5187 : ! tran and ref from below times interface scattering
5188 : ! fdirup(k) = (trndir(k)*rupdir(k) + &
5189 : ! (trntdr(k)-trndir(k)) & ! LCOV_EXCL_LINE
5190 : ! *rupdif(k))*refk
5191 : ! dir tran plus total diff trans times interface scattering plus
5192 : ! dir tran with up dir ref and down dif ref times interface scattering
5193 : ! fdirdn(k) = trndir(k) + (trntdr(k) &
5194 : ! - trndir(k) + trndir(k) & ! LCOV_EXCL_LINE
5195 : ! *rupdir(k)*rdndif(k))*refk
5196 : ! diffuse tran ref from below times interface scattering
5197 : ! fdifup(k) = trndif(k)*rupdif(k)*refk
5198 : ! diffuse tran times interface scattering
5199 : ! fdifdn(k) = trndif(k)*refk
5200 :
5201 : ! dfdir = fdirdn - fdirup
5202 0 : dfdir(k) = trndir(k) &
5203 : + (trntdr(k)-trndir(k)) * (c1 - rupdif(k)) * refk & ! LCOV_EXCL_LINE
5204 0 : - trndir(k)*rupdir(k) * (c1 - rdndif(k)) * refk
5205 0 : if (dfdir(k) < puny) dfdir(k) = c0 !echmod necessary?
5206 : ! dfdif = fdifdn - fdifup
5207 0 : dfdif(k) = trndif(k) * (c1 - rupdif(k)) * refk
5208 0 : if (dfdif(k) < puny) dfdif(k) = c0 !echmod necessary?
5209 : enddo ! k
5210 :
5211 : ! note that because the snow IOPs for diffuse and direct incidents
5212 : ! are different, the snow albedo needs to be calculated twice for
5213 : ! direct incident and diffuse incident respectively
5214 0 : if (nsky == 1) then ! direct beam (keep the direct beam results)
5215 0 : do k = 0, klevp
5216 0 : dfdir_snicar(k) = dfdir(k)
5217 0 : rupdir_snicar(k) = rupdir(k)
5218 : enddo
5219 0 : elseif (nsky == 2) then ! diffuse (keep the diffuse incident results)
5220 0 : do k = 0, klevp
5221 0 : dfdif_snicar(k) = dfdif(k)
5222 0 : rupdif_snicar(k) = rupdif(k)
5223 : enddo
5224 : endif
5225 : enddo ! end direct/diffuse nsky loop ------------------------------------
5226 :
5227 : ! calculate final surface albedos and fluxes
5228 : ! all absorbed flux above ksrf is included in surface absorption
5229 0 : if (ns == 1) then ! visible
5230 0 : swdr = swvdr
5231 0 : swdf = swvdf
5232 0 : avdr = rupdir_snicar(0)
5233 0 : avdf = rupdif_snicar(0)
5234 0 : tmp_0 = dfdir_snicar(0 )*swdr + dfdif_snicar(0 )*swdf
5235 0 : tmp_ks = dfdir_snicar(ksrf )*swdr + dfdif_snicar(ksrf )*swdf
5236 0 : tmp_kl = dfdir_snicar(klevp)*swdr + dfdif_snicar(klevp)*swdf
5237 :
5238 : ! for layer biology: save visible only
5239 0 : do k = nslyr+2, klevp ! Start at DL layer of ice after SSL scattering
5240 0 : fthrul(k-nslyr-1) = dfdir_snicar(k)*swdr + dfdif_snicar(k)*swdf
5241 : enddo
5242 :
5243 0 : fsfc = fsfc + tmp_0 - tmp_ks
5244 0 : fint = fint + tmp_ks - tmp_kl
5245 0 : fthru = fthru + tmp_kl
5246 0 : fthruvdr = fthruvdr + dfdir_snicar(klevp)*swdr
5247 0 : fthruvdf = fthruvdf + dfdif_snicar(klevp)*swdf
5248 :
5249 : ! if snow covered ice, set snow internal absorption; else, Sabs=0
5250 0 : if (srftyp == 1) then
5251 0 : ki = 0
5252 0 : do k = 1, nslyr
5253 : ! skip snow SSL, since SSL absorption included in the surface
5254 : ! absorption fsfc above
5255 0 : km = k
5256 0 : kp = km + 1
5257 0 : ki = ki + 1
5258 0 : Sabs(ki) = Sabs(ki) &
5259 : + dfdir_snicar(km)*swdr + dfdif_snicar(km)*swdf & ! LCOV_EXCL_LINE
5260 0 : - (dfdir_snicar(kp)*swdr + dfdif_snicar(kp)*swdf)
5261 : enddo ! k
5262 : endif
5263 :
5264 : ! complex indexing to insure proper absorptions for sea ice
5265 0 : ki = 0
5266 0 : do k = nslyr+2, nslyr+1+nilyr
5267 : ! for bare ice, DL absorption for sea ice layer 1
5268 0 : km = k
5269 0 : kp = km + 1
5270 : ! modify for top sea ice layer for snow over sea ice
5271 0 : if (srftyp == 1) then
5272 : ! must add SSL and DL absorption for sea ice layer 1
5273 0 : if (k == nslyr+2) then
5274 0 : km = k - 1
5275 0 : kp = km + 2
5276 : endif
5277 : endif
5278 0 : ki = ki + 1
5279 0 : Iabs(ki) = Iabs(ki) &
5280 : + dfdir_snicar(km)*swdr + dfdif_snicar(km)*swdf & ! LCOV_EXCL_LINE
5281 0 : - (dfdir_snicar(kp)*swdr + dfdif_snicar(kp)*swdf)
5282 : enddo ! k
5283 :
5284 : else ! ns > 1, near IR
5285 :
5286 0 : swdr = swidr
5287 0 : swdf = swidf
5288 :
5289 : ! let fr2(3,4,5) = alb_2(3,4,5)*swd*wght2(3,4,5)
5290 : ! the ns=2(3,4,5) reflected fluxes respectively,
5291 : ! where alb_2(3,4,5) are the band
5292 : ! albedos, swd = nir incident shortwave flux, and wght2(3,4,5) are
5293 : ! the 2(3,4,5) band weights. thus, the total reflected flux is:
5294 : ! fr = fr2 + fr3 + fr4 + fr5
5295 : ! = alb_2*swd*wght2 + alb_3*swd*wght3 + alb_4*swd*wght4 + alb_5*swd*wght5
5296 : ! hence, the 2,3,4,5 nir band albedo is
5297 : ! alb = fr/swd = alb_2*wght2 + alb_3*wght3 + alb_4*wght4 + alb_5*wght5
5298 :
5299 0 : aidr = aidr + rupdir_snicar(0)*wghtns_5bd_drc(ns)
5300 0 : aidf = aidf + rupdif_snicar(0)*wghtns_5bd_dfs(ns)
5301 :
5302 0 : tmp_0 = dfdir_snicar(0 )*swdr*wghtns_5bd_drc(ns) &
5303 0 : + dfdif_snicar(0 )*swdf*wghtns_5bd_dfs(ns)
5304 0 : tmp_ks = dfdir_snicar(ksrf )*swdr*wghtns_5bd_drc(ns) &
5305 0 : + dfdif_snicar(ksrf )*swdf*wghtns_5bd_dfs(ns)
5306 0 : tmp_kl = dfdir_snicar(klevp)*swdr*wghtns_5bd_drc(ns) &
5307 0 : + dfdif_snicar(klevp)*swdf*wghtns_5bd_dfs(ns)
5308 :
5309 0 : fsfc = fsfc + tmp_0 - tmp_ks
5310 0 : fint = fint + tmp_ks - tmp_kl
5311 0 : fthru = fthru + tmp_kl
5312 0 : fthruidr = fthruidr + dfdir_snicar(klevp)*swdr*wghtns_5bd_drc(ns)
5313 0 : fthruidf = fthruidf + dfdif_snicar(klevp)*swdf*wghtns_5bd_dfs(ns)
5314 :
5315 : ! if snow covered ice, set snow internal absorption; else, Sabs=0
5316 0 : if (srftyp == 1) then
5317 0 : ki = 0
5318 0 : do k = 1, nslyr
5319 : ! skip snow SSL, since SSL absorption included in the surface
5320 : ! absorption fsfc above
5321 0 : km = k
5322 0 : kp = km + 1
5323 0 : ki = ki + 1
5324 0 : Sabs(ki) = Sabs(ki) &
5325 : + dfdir_snicar(km)*swdr*wghtns_5bd_drc(ns) & ! LCOV_EXCL_LINE
5326 : + dfdif_snicar(km)*swdf*wghtns_5bd_dfs(ns) & ! LCOV_EXCL_LINE
5327 : - dfdir_snicar(kp)*swdr*wghtns_5bd_drc(ns) & ! LCOV_EXCL_LINE
5328 0 : - dfdif_snicar(kp)*swdf*wghtns_5bd_dfs(ns)
5329 : enddo ! k
5330 : endif
5331 :
5332 : ! complex indexing to insure proper absorptions for sea ice
5333 0 : ki = 0
5334 0 : do k = nslyr+2, nslyr+1+nilyr
5335 : ! for bare ice, DL absorption for sea ice layer 1
5336 0 : km = k
5337 0 : kp = km + 1
5338 : ! modify for top sea ice layer for snow over sea ice
5339 0 : if (srftyp == 1) then
5340 : ! must add SSL and DL absorption for sea ice layer 1
5341 0 : if (k == nslyr+2) then
5342 0 : km = k - 1
5343 0 : kp = km + 2
5344 : endif
5345 : endif
5346 0 : ki = ki + 1
5347 0 : Iabs(ki) = Iabs(ki) &
5348 : + dfdir_snicar(km)*swdr*wghtns_5bd_drc(ns) & ! LCOV_EXCL_LINE
5349 : + dfdif_snicar(km)*swdf*wghtns_5bd_dfs(ns) & ! LCOV_EXCL_LINE
5350 : - dfdir_snicar(kp)*swdr*wghtns_5bd_drc(ns) & ! LCOV_EXCL_LINE
5351 0 : - dfdif_snicar(kp)*swdf*wghtns_5bd_dfs(ns)
5352 : enddo ! k
5353 : endif ! ns
5354 : enddo ! ns: end spectral loop
5355 :
5356 : ! solar zenith angle parameterization
5357 : ! calculate the scaling factor for NIR direct albedo if SZA>75 degrees
5358 0 : sza_factor = c1
5359 0 : if (srftyp == 1) then
5360 0 : mu0 = max(coszen, p01)
5361 0 : if (mu0 < mu_75) then
5362 0 : sza_c1 = sza_a0 + sza_a1 * mu0 + sza_a2 * mu0**2
5363 0 : sza_c0 = sza_b0 + sza_b1 * mu0 + sza_b2 * mu0**2
5364 0 : sza_factor = sza_c1 * (log10(rsnw(1)) - 6.0_dbl_kind) + sza_c0
5365 : endif
5366 : endif
5367 :
5368 0 : alvdr = avdr
5369 0 : alvdf = avdf
5370 0 : alidr = aidr * sza_factor !sza factor is always larger than or equal to 1
5371 0 : alidf = aidf
5372 :
5373 : ! accumulate fluxes over bare sea ice
5374 :
5375 : ! note that we assume the reduced NIR energy absorption by snow
5376 : ! due to corrected snow albedo is absorbed by the snow single
5377 : ! scattering layer only - this is generally true if snow SSL >= 2 cm
5378 : ! by the default model set up:
5379 : ! if snow_depth >= 8 cm, SSL = 4 cm, satisfy
5380 : ! else if snow_depth >= 4 cm, SSL = snow_depth/2 >= 2 cm, satisfy
5381 : ! else snow_depth < 4 cm, SSL = snow_depth/2, may overcool SSL layer
5382 0 : fswsfc = fswsfc + (fsfc- (sza_factor-c1)*aidr*swidr)*fi
5383 0 : fswint = fswint + fint *fi
5384 0 : fswthru = fswthru + fthru*fi
5385 0 : fswthru_vdr = fswthru_vdr + fthruvdr*fi
5386 0 : fswthru_vdf = fswthru_vdf + fthruvdf*fi
5387 0 : fswthru_idr = fswthru_idr + fthruidr*fi
5388 0 : fswthru_idf = fswthru_idf + fthruidf*fi
5389 :
5390 0 : do k = 1, nslyr
5391 0 : Sswabs(k) = Sswabs(k) + Sabs(k)*fi
5392 : enddo
5393 :
5394 0 : do k = 1, nilyr
5395 0 : Iswabs(k) = Iswabs(k) + Iabs(k)*fi
5396 : ! bgc layer
5397 0 : fswpenl(k) = fswpenl(k) + fthrul(k)*fi
5398 : enddo
5399 0 : fswpenl(nilyr+1) = fswpenl(nilyr+1) + fthrul(nilyr+1)*fi
5400 :
5401 0 : end subroutine compute_dEdd_5bd
5402 :
5403 : !=======================================================================
5404 :
5405 : end module icepack_shortwave
5406 :
5407 : !=======================================================================
|
