Context Navigation

radiation_cloud_optics.F90 @ 5411

Last change on this file since 5411 was 5185, checked in by abarral, 3 months ago
Replace REPROBUS CPP KEY by logical using handmade wonky wrapper
File size: 23.2 KB

Line
1	! radiation_cloud_optics.F90 - Computing cloud optical properties
2
3	! (C) Copyright 2014- ECMWF.
4
5	! This software is licensed under the terms of the Apache Licence Version 2.0
6	! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
7
8	! In applying this licence, ECMWF does not waive the privileges and immunities
9	! granted to it by virtue of its status as an intergovernmental organisation
10	! nor does it submit to any jurisdiction.
11
12	! Author: Robin Hogan
13	! Email: r.j.hogan@ecmwf.int
14
15	! Modifications
16	! 2017-07-22 R. Hogan Added Yi et al. ice optics model
17
18	module radiation_cloud_optics
19
20	implicit none
21
22	public
23
24	contains
25
26	! Provides elemental function "delta_eddington_scat_od"
27	#include "radiation_delta_eddington.h"
28
29	!---------------------------------------------------------------------
30	! Load cloud scattering data; this subroutine delegates to one
31	! in radiation_cloud_optics_data.F90, but checks the size of
32	! what is returned
33	subroutine setup_cloud_optics(config)
34
35	use parkind1, only : jprb
36	use yomhook, only : lhook, dr_hook
37
38	use radiation_io, only : nulerr, radiation_abort
39	use radiation_config, only : config_type, IIceModelFu, IIceModelBaran, &
40	& IIceModelBaran2016, IIceModelBaran2017, &
41	& IIceModelYi, &
42	& ILiquidModelSOCRATES, ILiquidModelSlingo
43	use radiation_cloud_optics_data, only : cloud_optics_type
44	use radiation_ice_optics_fu, only : NIceOpticsCoeffsFuSW, &
45	& NIceOpticsCoeffsFuLW
46	use radiation_ice_optics_baran, only : NIceOpticsCoeffsBaran, &
47	& NIceOpticsCoeffsBaran2016
48	use radiation_ice_optics_baran2017, only : NIceOpticsCoeffsBaran2017, &
49	& NIceOpticsGeneralCoeffsBaran2017
50	use radiation_ice_optics_yi, only : NIceOpticsCoeffsYiSW, &
51	& NIceOpticsCoeffsYiLW
52	use radiation_liquid_optics_socrates, only : NLiqOpticsCoeffsSOCRATES
53	use radiation_liquid_optics_slingo, only : NLiqOpticsCoeffsSlingoSW, &
54	& NLiqOpticsCoeffsLindnerLiLW
55
56	type(config_type), intent(inout) :: config
57
58	real(jprb) :: hook_handle
59
60	if (lhook) call dr_hook('radiation_cloud_optics:setup_cloud_optics',0,hook_handle)
61
62	call config%cloud_optics%setup(trim(config%liq_optics_file_name), &
63	& trim(config%ice_optics_file_name), iverbose=config%iverbosesetup)
64
65	! Check liquid coefficients
66	if (size(config%cloud_optics%liq_coeff_lw, 1) /= config%n_bands_lw) then
67	write(nulerr,'(a,i0,a,i0,a)') &
68	& '*** Error: number of longwave bands for droplets (', &
69	& size(config%cloud_optics%liq_coeff_lw, 1), &
70	& ') does not match number for gases (', config%n_bands_lw, ')'
71	call radiation_abort()
72	end if
73	if (size(config%cloud_optics%liq_coeff_sw, 1) /= config%n_bands_sw) then
74	write(nulerr,'(a,i0,a,i0,a)') &
75	& '*** Error: number of shortwave bands for droplets (', &
76	& size(config%cloud_optics%liq_coeff_sw, 1), &
77	& ') does not match number for gases (', config%n_bands_sw, ')'
78	call radiation_abort()
79	end if
80
81	if (config%i_liq_model == ILiquidModelSOCRATES) then
82	if (size(config%cloud_optics%liq_coeff_lw, 2) /= NLiqOpticsCoeffsSOCRATES) then
83	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
84	& '*** Error: number of liquid cloud optical coefficients (', &
85	& size(config%cloud_optics%liq_coeff_lw, 2), &
86	& ') does not match number expected (', NLiqOpticsCoeffsSOCRATES,')'
87	call radiation_abort()
88	end if
89	else if (config%i_liq_model == ILiquidModelSlingo) then
90	if (size(config%cloud_optics%liq_coeff_sw, 2) /= NLiqOpticsCoeffsSlingoSW) then
91	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
92	& '*** Error: number of shortwave liquid cloud optical coefficients (', &
93	& size(config%cloud_optics%liq_coeff_sw, 2), &
94	& ') does not match number expected (', NLiqOpticsCoeffsSlingoSW,')'
95	call radiation_abort()
96	end if
97	if (size(config%cloud_optics%liq_coeff_lw, 2) /= NLiqOpticsCoeffsLindnerLiLW) then
98	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
99	& '*** Error: number of longwave liquid cloud optical coefficients (', &
100	& size(config%cloud_optics%liq_coeff_lw, 2), &
101	& ') does not match number expected (', NLiqOpticsCoeffsLindnerLiLw,')'
102	call radiation_abort()
103	end if
104	end if
105
106	! Check ice coefficients
107	if (size(config%cloud_optics%ice_coeff_lw, 1) /= config%n_bands_lw) then
108	write(nulerr,'(a,i0,a,i0,a)') &
109	& '*** Error: number of longwave bands for ice particles (', &
110	& size(config%cloud_optics%ice_coeff_lw, 1), &
111	& ') does not match number for gases (', config%n_bands_lw, ')'
112	call radiation_abort()
113	end if
114	if (size(config%cloud_optics%ice_coeff_sw, 1) /= config%n_bands_sw) then
115	write(nulerr,'(a,i0,a,i0,a)') &
116	& '*** Error: number of shortwave bands for ice particles (', &
117	& size(config%cloud_optics%ice_coeff_sw, 1), &
118	& ') does not match number for gases (', config%n_bands_sw, ')'
119	call radiation_abort()
120	end if
121
122	if (config%i_ice_model == IIceModelFu) then
123	if (size(config%cloud_optics%ice_coeff_lw, 2) &
124	& /= NIceOpticsCoeffsFuLW) then
125	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
126	& '*** Error: number of LW ice-particle optical coefficients (', &
127	& size(config%cloud_optics%ice_coeff_lw, 2), &
128	& ') does not match number expected (', NIceOpticsCoeffsFuLW,')'
129	call radiation_abort()
130	end if
131	if (size(config%cloud_optics%ice_coeff_sw, 2) &
132	& /= NIceOpticsCoeffsFuSW) then
133	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
134	& '*** Error: number of SW ice-particle optical coefficients (', &
135	& size(config%cloud_optics%ice_coeff_sw, 2), &
136	& ') does not match number expected (', NIceOpticsCoeffsFuSW,')'
137	call radiation_abort()
138	end if
139	else if (config%i_ice_model == IIceModelBaran &
140	& .AND. size(config%cloud_optics%ice_coeff_lw, 2) &
141	& /= NIceOpticsCoeffsBaran) then
142	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
143	& '*** Error: number of ice-particle optical coefficients (', &
144	& size(config%cloud_optics%ice_coeff_lw, 2), &
145	& ') does not match number expected (', NIceOpticsCoeffsBaran,')'
146	call radiation_abort()
147	else if (config%i_ice_model == IIceModelBaran2016 &
148	& .AND. size(config%cloud_optics%ice_coeff_lw, 2) &
149	& /= NIceOpticsCoeffsBaran2016) then
150	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
151	& '*** Error: number of ice-particle optical coefficients (', &
152	& size(config%cloud_optics%ice_coeff_lw, 2), &
153	& ') does not match number expected (', NIceOpticsCoeffsBaran2016,')'
154	call radiation_abort()
155	else if (config%i_ice_model == IIceModelBaran2017) then
156	if (size(config%cloud_optics%ice_coeff_lw, 2) &
157	& /= NIceOpticsCoeffsBaran2017) then
158	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
159	& '*** Error: number of ice-particle optical coefficients (', &
160	& size(config%cloud_optics%ice_coeff_lw, 2), &
161	& ') does not match number expected (', NIceOpticsCoeffsBaran2017,')'
162	call radiation_abort()
163	else if (.not. allocated(config%cloud_optics%ice_coeff_gen)) then
164	write(nulerr,'(a)') &
165	& '*** Error: coeff_gen needed for Baran-2017 ice optics parameterization'
166	call radiation_abort()
167	else if (size(config%cloud_optics%ice_coeff_gen) &
168	& /= NIceOpticsGeneralCoeffsBaran2017) then
169	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
170	& '*** Error: number of general ice-particle optical coefficients (', &
171	& size(config%cloud_optics%ice_coeff_gen), &
172	& ') does not match number expected (', NIceOpticsGeneralCoeffsBaran2017,')'
173	call radiation_abort()
174	end if
175	else if (config%i_ice_model == IIceModelYi) then
176	if (size(config%cloud_optics%ice_coeff_lw, 2) &
177	& /= NIceOpticsCoeffsYiLW) then
178	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
179	& '*** Error: number of LW ice-particle optical coefficients (', &
180	& size(config%cloud_optics%ice_coeff_lw, 2), &
181	& ') does not match number expected (', NIceOpticsCoeffsYiLW,')'
182	call radiation_abort()
183	end if
184	if (size(config%cloud_optics%ice_coeff_sw, 2) &
185	& /= NIceOpticsCoeffsYiSW) then
186	write(nulerr,'(a,i0,a,i0,a,i0,a)') &
187	& '*** Error: number of SW ice-particle optical coefficients (', &
188	& size(config%cloud_optics%ice_coeff_sw, 2), &
189	& ') does not match number expected (', NIceOpticsCoeffsYiSW,')'
190	call radiation_abort()
191	end if
192	end if
193
194	if (lhook) call dr_hook('radiation_cloud_optics:setup_cloud_optics',1,hook_handle)
195
196	end subroutine setup_cloud_optics
197
198
199	!---------------------------------------------------------------------
200	! Compute cloud optical properties
201	subroutine cloud_optics(nlev,istartcol,iendcol, &
202	& config, thermodynamics, cloud, &
203	& od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
204	& od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
205
206	use parkind1, only : jprb
207	use yomhook, only : lhook, dr_hook
208
209	use radiation_io, only : nulout, nulerr, radiation_abort
210	use radiation_config, only : config_type, IIceModelFu, IIceModelBaran, &
211	& IIceModelBaran2016, IIceModelBaran2017, &
212	& IIceModelYi, &
213	& ILiquidModelSOCRATES, ILiquidModelSlingo
214	use radiation_thermodynamics, only : thermodynamics_type
215	use radiation_cloud, only : cloud_type
216	use radiation_constants, only : AccelDueToGravity
217	use radiation_cloud_optics_data, only : cloud_optics_type
218	use radiation_ice_optics_fu, only : calc_ice_optics_fu_sw, &
219	& calc_ice_optics_fu_lw
220	use radiation_ice_optics_baran, only : calc_ice_optics_baran, &
221	& calc_ice_optics_baran2016
222	use radiation_ice_optics_baran2017, only : calc_ice_optics_baran2017
223	use radiation_ice_optics_yi, only : calc_ice_optics_yi_sw, &
224	& calc_ice_optics_yi_lw
225	use radiation_liquid_optics_socrates, only:calc_liq_optics_socrates
226	use radiation_liquid_optics_slingo, only:calc_liq_optics_slingo, &
227	& calc_liq_optics_lindner_li
228
229	integer, intent(in) :: nlev ! number of model levels
230	integer, intent(in) :: istartcol, iendcol ! range of columns to process
231	type(config_type), intent(in), target :: config
232	type(thermodynamics_type),intent(in) :: thermodynamics
233	type(cloud_type), intent(in) :: cloud
234
235	! Layer optical depth, single scattering albedo and g factor of
236	! clouds in each longwave band, where the latter two
237	! variables are only defined if cloud longwave scattering is
238	! enabled (otherwise both are treated as zero).
239	real(jprb), dimension(config%n_bands_lw,nlev,istartcol:iendcol), intent(out) :: &
240	& od_lw_cloud
241	real(jprb), dimension(config%n_bands_lw_if_scattering,nlev,istartcol:iendcol), &
242	& intent(out) :: ssa_lw_cloud, g_lw_cloud
243
244	! Layer optical depth, single scattering albedo and g factor of
245	! clouds in each shortwave band
246	real(jprb), dimension(config%n_bands_sw,nlev,istartcol:iendcol), intent(out) :: &
247	& od_sw_cloud, ssa_sw_cloud, g_sw_cloud
248
249	! Longwave and shortwave optical depth, scattering optical depth
250	! and asymmetry factor, for liquid and ice in all bands but a
251	! single cloud layer
252	real(jprb), dimension(config%n_bands_lw) :: &
253	& od_lw_liq, scat_od_lw_liq, g_lw_liq, &
254	& od_lw_ice, scat_od_lw_ice, g_lw_ice
255	real(jprb), dimension(config%n_bands_sw) :: &
256	& od_sw_liq, scat_od_sw_liq, g_sw_liq, &
257	& od_sw_ice, scat_od_sw_ice, g_sw_ice
258
259	! In-cloud water path of cloud liquid or ice (i.e. liquid or ice
260	! gridbox-mean water path divided by cloud fraction); kg m-2
261	real(jprb) :: lwp_in_cloud, iwp_in_cloud
262
263	! Full-level temperature (K)
264	real(jprb) :: temperature
265
266	! Factor to convert gridbox-mean mixing ratio to in-cloud water
267	! path
268	real(jprb) :: factor
269
270	! Pointer to the cloud optics coefficients for brevity of
271	! access
272	type(cloud_optics_type), pointer :: ho
273
274	integer :: jcol, jlev, jb
275
276	real(jprb) :: hook_handle
277
278	if (lhook) call dr_hook('radiation_cloud_optics:cloud_optics',0,hook_handle)
279
280	if (config%iverbose >= 2) then
281	write(nulout,'(a)') 'Computing cloud absorption/scattering properties'
282	end if
283
284	ho => config%cloud_optics
285
286	! Array-wise assignment
287	od_lw_cloud = 0.0_jprb
288	od_sw_cloud = 0.0_jprb
289	ssa_sw_cloud = 0.0_jprb
290	g_sw_cloud = 0.0_jprb
291	if (config%do_lw_cloud_scattering) then
292	ssa_lw_cloud = 0.0_jprb
293	g_lw_cloud = 0.0_jprb
294	end if
295
296	DO jlev = 1,nlev
297	DO jcol = istartcol,iendcol
298	! Only do anything if cloud is present (assume that
299	! cloud%crop_cloud_fraction has already been called)
300	if (cloud%fraction(jcol,jlev) > 0.0_jprb) then
301
302	! Compute in-cloud liquid and ice water path
303	if (config%is_homogeneous) then
304	! Homogeneous solvers assume cloud fills the box
305	! horizontally, so we don't divide by cloud fraction
306	factor = ( thermodynamics%pressure_hl(jcol,jlev+1) &
307	& -thermodynamics%pressure_hl(jcol,jlev ) ) &
308	& / AccelDueToGravity
309	else
310	factor = ( thermodynamics%pressure_hl(jcol,jlev+1) &
311	& -thermodynamics%pressure_hl(jcol,jlev ) ) &
312	& / (AccelDueToGravity * cloud%fraction(jcol,jlev))
313	end if
314	lwp_in_cloud = factor * cloud%q_liq(jcol,jlev)
315	iwp_in_cloud = factor * cloud%q_ice(jcol,jlev)
316
317	! Only compute liquid properties if liquid cloud is
318	! present
319	if (lwp_in_cloud > 0.0_jprb) then
320	if (config%i_liq_model == ILiquidModelSOCRATES) then
321	! Compute longwave properties
322	call calc_liq_optics_socrates(config%n_bands_lw, &
323	& config%cloud_optics%liq_coeff_lw, &
324	& lwp_in_cloud, cloud%re_liq(jcol,jlev), &
325	& od_lw_liq, scat_od_lw_liq, g_lw_liq)
326	! Compute shortwave properties
327	call calc_liq_optics_socrates(config%n_bands_sw, &
328	& config%cloud_optics%liq_coeff_sw, &
329	& lwp_in_cloud, cloud%re_liq(jcol,jlev), &
330	& od_sw_liq, scat_od_sw_liq, g_sw_liq)
331	else if (config%i_liq_model == ILiquidModelSlingo) then
332	! Compute longwave properties
333	call calc_liq_optics_lindner_li(config%n_bands_lw, &
334	& config%cloud_optics%liq_coeff_lw, &
335	& lwp_in_cloud, cloud%re_liq(jcol,jlev), &
336	& od_lw_liq, scat_od_lw_liq, g_lw_liq)
337	! Compute shortwave properties
338	call calc_liq_optics_slingo(config%n_bands_sw, &
339	& config%cloud_optics%liq_coeff_sw, &
340	& lwp_in_cloud, cloud%re_liq(jcol,jlev), &
341	& od_sw_liq, scat_od_sw_liq, g_sw_liq)
342	else
343	write(nulerr,) '** Error: Unknown liquid model with code', &
344	& config%i_liq_model
345	call radiation_abort()
346	end if
347
348	! Delta-Eddington scaling in the shortwave only
349	if (.not. config%do_sw_delta_scaling_with_gases) then
350	call delta_eddington_scat_od(od_sw_liq, scat_od_sw_liq, g_sw_liq)
351	end if
352	!call delta_eddington_scat_od(od_lw_liq, scat_od_lw_liq, g_lw_liq)
353
354	else
355	! Liquid not present: set properties to zero
356	od_lw_liq = 0.0_jprb
357	scat_od_lw_liq = 0.0_jprb
358	g_lw_liq = 0.0_jprb
359
360	od_sw_liq = 0.0_jprb
361	scat_od_sw_liq = 0.0_jprb
362	g_sw_liq = 0.0_jprb
363	end if ! Liquid present
364
365	! Only compute ice properties if ice cloud is present
366	if (iwp_in_cloud > 0.0_jprb) then
367	if (config%i_ice_model == IIceModelBaran) then
368	! Compute longwave properties
369	call calc_ice_optics_baran(config%n_bands_lw, &
370	& config%cloud_optics%ice_coeff_lw, &
371	& iwp_in_cloud, cloud%q_ice(jcol,jlev), &
372	& od_lw_ice, scat_od_lw_ice, g_lw_ice)
373	! Compute shortwave properties
374	call calc_ice_optics_baran(config%n_bands_sw, &
375	& config%cloud_optics%ice_coeff_sw, &
376	& iwp_in_cloud, cloud%q_ice(jcol,jlev), &
377	& od_sw_ice, scat_od_sw_ice, g_sw_ice)
378	else if (config%i_ice_model == IIceModelBaran2016) then
379	temperature = 0.5_jprb * (thermodynamics%temperature_hl(jcol,jlev) &
380	& +thermodynamics%temperature_hl(jcol,jlev+1))
381	! Compute longwave properties
382	call calc_ice_optics_baran2016(config%n_bands_lw, &
383	& config%cloud_optics%ice_coeff_lw, &
384	& iwp_in_cloud, cloud%q_ice(jcol,jlev), &
385	& temperature, &
386	& od_lw_ice, scat_od_lw_ice, g_lw_ice)
387	! Compute shortwave properties
388	call calc_ice_optics_baran2016(config%n_bands_sw, &
389	& config%cloud_optics%ice_coeff_sw, &
390	& iwp_in_cloud, cloud%q_ice(jcol,jlev), &
391	& temperature, &
392	& od_sw_ice, scat_od_sw_ice, g_sw_ice)
393	else if (config%i_ice_model == IIceModelBaran2017) then
394	temperature = 0.5_jprb * (thermodynamics%temperature_hl(jcol,jlev) &
395	& +thermodynamics%temperature_hl(jcol,jlev+1))
396	! Compute longwave properties
397	call calc_ice_optics_baran2017(config%n_bands_lw, &
398	& config%cloud_optics%ice_coeff_gen, &
399	& config%cloud_optics%ice_coeff_lw, &
400	& iwp_in_cloud, cloud%q_ice(jcol,jlev), &
401	& temperature, &
402	& od_lw_ice, scat_od_lw_ice, g_lw_ice)
403	! Compute shortwave properties
404	call calc_ice_optics_baran2017(config%n_bands_sw, &
405	& config%cloud_optics%ice_coeff_gen, &
406	& config%cloud_optics%ice_coeff_sw, &
407	& iwp_in_cloud, cloud%q_ice(jcol,jlev), &
408	& temperature, &
409	& od_sw_ice, scat_od_sw_ice, g_sw_ice)
410	else if (config%i_ice_model == IIceModelFu) then
411	! Compute longwave properties
412	call calc_ice_optics_fu_lw(config%n_bands_lw, &
413	& config%cloud_optics%ice_coeff_lw, &
414	& iwp_in_cloud, cloud%re_ice(jcol,jlev), &
415	& od_lw_ice, scat_od_lw_ice, g_lw_ice)
416	if (config%do_fu_lw_ice_optics_bug) then
417	! Reproduce bug in old IFS scheme
418	scat_od_lw_ice = od_lw_ice - scat_od_lw_ice
419	end if
420	! Compute shortwave properties
421	call calc_ice_optics_fu_sw(config%n_bands_sw, &
422	& config%cloud_optics%ice_coeff_sw, &
423	& iwp_in_cloud, cloud%re_ice(jcol,jlev), &
424	& od_sw_ice, scat_od_sw_ice, g_sw_ice)
425	else if (config%i_ice_model == IIceModelYi) then
426	! Compute longwave properties
427	call calc_ice_optics_yi_lw(config%n_bands_lw, &
428	& config%cloud_optics%ice_coeff_lw, &
429	& iwp_in_cloud, cloud%re_ice(jcol,jlev), &
430	& od_lw_ice, scat_od_lw_ice, g_lw_ice)
431	! Compute shortwave properties
432	call calc_ice_optics_yi_sw(config%n_bands_sw, &
433	& config%cloud_optics%ice_coeff_sw, &
434	& iwp_in_cloud, cloud%re_ice(jcol,jlev), &
435	& od_sw_ice, scat_od_sw_ice, g_sw_ice)
436	else
437	write(nulerr,) '** Error: Unknown ice model with code', &
438	& config%i_ice_model
439	call radiation_abort()
440	end if
441
442	! Delta-Eddington scaling in both longwave and shortwave
443	! (assume that particles are larger than wavelength even
444	! in longwave)
445	if (.not. config%do_sw_delta_scaling_with_gases) then
446	call delta_eddington_scat_od(od_sw_ice, scat_od_sw_ice, g_sw_ice)
447	end if
448	call delta_eddington_scat_od(od_lw_ice, scat_od_lw_ice, g_lw_ice)
449
450	else
451	! Ice not present: set properties to zero
452	od_lw_ice = 0.0_jprb
453	scat_od_lw_ice = 0.0_jprb
454	g_lw_ice = 0.0_jprb
455
456	od_sw_ice = 0.0_jprb
457	scat_od_sw_ice = 0.0_jprb
458	g_sw_ice = 0.0_jprb
459	end if ! Ice present
460
461	! Combine liquid and ice
462	if (config%do_lw_cloud_scattering) then
463	! Added for DWD (2020)
464	!NEC$ shortloop
465	DO jb = 1, config%n_bands_lw
466	od_lw_cloud(jb,jlev,jcol) = od_lw_liq(jb) + od_lw_ice(jb)
467	if (scat_od_lw_liq(jb)+scat_od_lw_ice(jb) > 0.0_jprb) then
468	g_lw_cloud(jb,jlev,jcol) = (g_lw_liq(jb) * scat_od_lw_liq(jb) &
469	& + g_lw_ice(jb) * scat_od_lw_ice(jb)) &
470	& / (scat_od_lw_liq(jb)+scat_od_lw_ice(jb))
471	else
472	g_lw_cloud(jb,jlev,jcol) = 0.0_jprb
473	end if
474	ssa_lw_cloud(jb,jlev,jcol) = (scat_od_lw_liq(jb) + scat_od_lw_ice(jb)) &
475	& / (od_lw_liq(jb) + od_lw_ice(jb))
476	end do
477	else
478	! If longwave scattering is to be neglected then the
479	! best approximation is to set the optical depth equal
480	! to the absorption optical depth
481	! Added for DWD (2020)
482	!NEC$ shortloop
483	DO jb = 1, config%n_bands_lw
484	od_lw_cloud(jb,jlev,jcol) = od_lw_liq(jb) - scat_od_lw_liq(jb) &
485	& + od_lw_ice(jb) - scat_od_lw_ice(jb)
486	end do
487	end if
488	! Added for DWD (2020)
489	!NEC$ shortloop
490	DO jb = 1, config%n_bands_sw
491	od_sw_cloud(jb,jlev,jcol) = od_sw_liq(jb) + od_sw_ice(jb)
492	g_sw_cloud(jb,jlev,jcol) = (g_sw_liq(jb) * scat_od_sw_liq(jb) &
493	& + g_sw_ice(jb) * scat_od_sw_ice(jb)) &
494	& / (scat_od_sw_liq(jb) + scat_od_sw_ice(jb))
495	ssa_sw_cloud(jb,jlev,jcol) &
496	& = (scat_od_sw_liq(jb) + scat_od_sw_ice(jb)) / (od_sw_liq(jb) + od_sw_ice(jb))
497	end do
498	end if ! Cloud present
499	end do ! Loop over column
500	end do ! Loop over level
501
502	if (lhook) call dr_hook('radiation_cloud_optics:cloud_optics',1,hook_handle)
503
504	end subroutine cloud_optics
505
506	end module radiation_cloud_optics

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format