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