Context Navigation

radiation_interface.F90 @ 5162

Last change on this file since 5162 was 4489, checked in by lguez, 20 months ago
Merge LMDZ_ECRad branch back into trunk!
File size: 27.7 KB

Line
1	! radiation_interface.F90 - Public interface to radiation scheme
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-04-11 R. Hogan Changes to enable generalized surface description
17	! 2017-09-08 R. Hogan Reverted some changes
18	!
19	! To use the radiation scheme, create a configuration_type object,
20	! call "setup_radiation" on it once to load the look-up-tables and
21	! data describing how gas and hydrometeor absorption/scattering are to
22	! be represented, and call "radiation" multiple times on different
23	! input profiles.
24
25	module radiation_interface
26
27	implicit none
28
29	public :: setup_radiation, set_gas_units, radiation
30	private :: radiation_reverse
31
32	contains
33
34	!---------------------------------------------------------------------
35	! Load the look-up-tables and data describing how gas and
36	! hydrometeor absorption/scattering are to be represented
37	subroutine setup_radiation(config)
38
39	use parkind1, only : jprb
40	use yomhook, only : lhook, dr_hook
41	use radiation_config, only : config_type, ISolverMcICA, &
42	& IGasModelMonochromatic, IGasModelIFSRRTMG, IGasModelECCKD
43	use radiation_spectral_definition, only &
44	& : SolarReferenceTemperature, TerrestrialReferenceTemperature
45
46	! Currently there are two gas absorption models: RRTMG (default)
47	! and monochromatic
48	use radiation_monochromatic, only : &
49	& setup_gas_optics_mono => setup_gas_optics, &
50	& setup_cloud_optics_mono => setup_cloud_optics, &
51	& setup_aerosol_optics_mono => setup_aerosol_optics
52	use radiation_ifs_rrtm, only : setup_gas_optics_rrtmg => setup_gas_optics
53	use radiation_ecckd_interface,only : setup_gas_optics_ecckd => setup_gas_optics
54	use radiation_cloud_optics, only : setup_cloud_optics
55	use radiation_general_cloud_optics, only : setup_general_cloud_optics
56	use radiation_aerosol_optics, only : setup_aerosol_optics
57
58	type(config_type), intent(inout) :: config
59
60	real(jprb) :: hook_handle
61
62	if (lhook) call dr_hook('radiation_interface:setup_radiation',0,hook_handle)
63
64	! Consolidate configuration data, including setting data file
65	! names
66	call config%consolidate()
67
68	! Load the look-up tables from files in the specified directory
69	if (config%i_gas_model == IGasModelMonochromatic) then
70	call setup_gas_optics_mono(config, trim(config%directory_name))
71	else if (config%i_gas_model == IGasModelIFSRRTMG) then
72	call setup_gas_optics_rrtmg(config, trim(config%directory_name))
73	else if (config%i_gas_model == IGasModelECCKD) then
74	call setup_gas_optics_ecckd(config)
75	end if
76
77	! Whether or not the "radiation" subroutine needs ssa_lw and g_lw
78	! arrays depends on whether longwave scattering by aerosols is to
79	! be included. If not, one of the array dimensions will be set to
80	! zero.
81	if (config%do_lw_aerosol_scattering) then
82	config%n_g_lw_if_scattering = config%n_g_lw
83	else
84	config%n_g_lw_if_scattering = 0
85	end if
86
87	! Whether or not the "radiation" subroutine needs ssa_lw_cloud and
88	! g_lw_cloud arrays depends on whether longwave scattering by
89	! hydrometeors is to be included. If not, one of the array
90	! dimensions will be set to zero.
91	if (config%do_lw_cloud_scattering) then
92	config%n_bands_lw_if_scattering = config%n_bands_lw
93	else
94	config%n_bands_lw_if_scattering = 0
95	end if
96
97	! If we have longwave scattering and McICA then even if there is
98	! no aerosol, it is convenient if single scattering albedo and
99	! g factor arrays are allocated before the call to
100	! solver_lw as they will be needed.
101	if (config%do_lw_cloud_scattering &
102	& .and. config%i_solver_lw == ISolverMcICA) then
103	config%n_g_lw_if_scattering = config%n_g_lw
104	end if
105
106	! Consolidate the albedo/emissivity intervals with the shortwave
107	! and longwave spectral bands
108	if (config%do_sw) then
109	call config%consolidate_sw_albedo_intervals
110	end if
111	if (config%do_lw) then
112	call config%consolidate_lw_emiss_intervals
113	end if
114
115	if (config%do_clouds) then
116	if (config%i_gas_model == IGasModelMonochromatic) then
117	! call setup_cloud_optics_mono(config)
118	elseif (config%use_general_cloud_optics) then
119	call setup_general_cloud_optics(config)
120	else
121	call setup_cloud_optics(config)
122	end if
123	end if
124
125	if (config%use_aerosols) then
126	if (config%i_gas_model == IGasModelMonochromatic) then
127	! call setup_aerosol_optics_mono(config)
128	else
129	call setup_aerosol_optics(config)
130	end if
131	end if
132
133	! Load cloud water PDF look-up table for McICA
134	if ( config%i_solver_sw == ISolverMcICA &
135	& .or. config%i_solver_lw == ISolverMcICA) then
136	call config%pdf_sampler%setup(config%cloud_pdf_file_name, &
137	& iverbose=config%iverbosesetup)
138	end if
139
140	if (lhook) call dr_hook('radiation_interface:setup_radiation',1,hook_handle)
141
142	end subroutine setup_radiation
143
144
145	!---------------------------------------------------------------------
146	! Scale the gas mixing ratios so that they have the units (and
147	! possibly scale factors) required by the specific gas absorption
148	! model. This subroutine simply passes the gas object on to the
149	! module of the currently active gas model.
150	subroutine set_gas_units(config, gas)
151
152	use radiation_config
153	use radiation_gas, only : gas_type
154	use radiation_monochromatic, only : set_gas_units_mono => set_gas_units
155	use radiation_ifs_rrtm, only : set_gas_units_ifs => set_gas_units
156	use radiation_ecckd_interface, only : set_gas_units_ecckd => set_gas_units
157
158	type(config_type), intent(in) :: config
159	type(gas_type), intent(inout) :: gas
160
161	if (config%i_gas_model == IGasModelMonochromatic) then
162	call set_gas_units_mono(gas)
163	elseif (config%i_gas_model == IGasModelECCKD) then
164	call set_gas_units_ecckd(gas)
165	else
166	call set_gas_units_ifs(gas)
167	end if
168
169	end subroutine set_gas_units
170
171
172	!---------------------------------------------------------------------
173	! Run the radiation scheme according to the configuration in the
174	! config object. There are ncol profiles of which only istartcol to
175	! iendcol are to be processed, and there are nlev model levels. The
176	! output fluxes are written to the flux object, and all other
177	! objects contain the input variables. The variables may be defined
178	! either in order of increasing or decreasing pressure, but if in
179	! order of decreasing pressure then radiation_reverse will be called
180	! to reverse the order for the computation and then reverse the
181	! order of the output fluxes to match the inputs.
182	subroutine radiation(ncol, nlev, istartcol, iendcol, config, &
183	& single_level, thermodynamics, gas, cloud, aerosol, flux)
184
185	use parkind1, only : jprb
186	use yomhook, only : lhook, dr_hook
187
188	use radiation_io, only : nulout
189	use radiation_config, only : config_type, &
190	& IGasModelMonochromatic, IGasModelIFSRRTMG, &
191	& ISolverMcICA, ISolverSpartacus, ISolverHomogeneous, &
192	& ISolverTripleclouds
193	use radiation_single_level, only : single_level_type
194	use radiation_thermodynamics, only : thermodynamics_type
195	use radiation_gas, only : gas_type
196	use radiation_cloud, only : cloud_type
197	use radiation_aerosol, only : aerosol_type
198	use radiation_flux, only : flux_type
199	use radiation_spartacus_sw, only : solver_spartacus_sw
200	use radiation_spartacus_lw, only : solver_spartacus_lw
201	use radiation_tripleclouds_sw,only : solver_tripleclouds_sw
202	use radiation_tripleclouds_lw,only : solver_tripleclouds_lw
203	use radiation_mcica_sw, only : solver_mcica_sw
204	use radiation_mcica_lw, only : solver_mcica_lw
205	use radiation_cloudless_sw, only : solver_cloudless_sw
206	use radiation_cloudless_lw, only : solver_cloudless_lw
207	use radiation_homogeneous_sw, only : solver_homogeneous_sw
208	use radiation_homogeneous_lw, only : solver_homogeneous_lw
209	use radiation_save, only : save_radiative_properties
210
211	! Treatment of gas and hydrometeor optics
212	use radiation_monochromatic, only : &
213	& gas_optics_mono => gas_optics, &
214	& cloud_optics_mono => cloud_optics, &
215	& add_aerosol_optics_mono => add_aerosol_optics
216	use radiation_ifs_rrtm, only : gas_optics_rrtmg => gas_optics
217	use radiation_ecckd_interface,only : gas_optics_ecckd => gas_optics
218	use radiation_cloud_optics, only : cloud_optics
219	use radiation_general_cloud_optics, only : general_cloud_optics
220	use radiation_aerosol_optics, only : add_aerosol_optics
221
222	! Inputs
223	integer, intent(in) :: ncol ! number of columns
224	integer, intent(in) :: nlev ! number of model levels
225	integer, intent(in) :: istartcol, iendcol ! range of columns to process
226	type(config_type), intent(in) :: config
227	type(single_level_type), intent(in) :: single_level
228	type(thermodynamics_type),intent(in) :: thermodynamics
229	type(gas_type), intent(in) :: gas
230	type(cloud_type), intent(inout):: cloud
231	type(aerosol_type), intent(in) :: aerosol
232	! Output
233	type(flux_type), intent(inout):: flux
234
235
236	! Local variables
237
238	! Layer optical depth, single scattering albedo and asymmetry factor of
239	! gases and aerosols at each longwave g-point, where the latter
240	! two variables are only defined if aerosol longwave scattering is
241	! enabled (otherwise both are treated as zero).
242	real(jprb), dimension(config%n_g_lw,nlev,istartcol:iendcol) :: od_lw
243	real(jprb), dimension(config%n_g_lw_if_scattering,nlev,istartcol:iendcol) :: &
244	& ssa_lw, g_lw
245
246	! Layer in-cloud optical depth, single scattering albedo and
247	! asymmetry factor of hydrometeors in each longwave band, where
248	! the latter two variables are only defined if hydrometeor
249	! longwave scattering is enabled (otherwise both are treated as
250	! zero).
251	real(jprb), dimension(config%n_bands_lw,nlev,istartcol:iendcol) :: od_lw_cloud
252	real(jprb), dimension(config%n_bands_lw_if_scattering,nlev,istartcol:iendcol) :: &
253	& ssa_lw_cloud, g_lw_cloud
254
255	! Layer optical depth, single scattering albedo and asymmetry factor of
256	! gases and aerosols at each shortwave g-point
257	real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol) :: od_sw, ssa_sw, g_sw
258
259	! Layer in-cloud optical depth, single scattering albedo and
260	! asymmetry factor of hydrometeors in each shortwave band
261	real(jprb), dimension(config%n_bands_sw,nlev,istartcol:iendcol) :: &
262	& od_sw_cloud, ssa_sw_cloud, g_sw_cloud
263
264	! The Planck function (emitted flux from a black body) at half
265	! levels
266	real(jprb), dimension(config%n_g_lw,nlev+1,istartcol:iendcol) :: planck_hl
267
268	! The longwave emission from and albedo of the surface in each
269	! longwave g-point; note that these are weighted averages of the
270	! values from individual tiles
271	real(jprb), dimension(config%n_g_lw, istartcol:iendcol) :: lw_emission
272	real(jprb), dimension(config%n_g_lw, istartcol:iendcol) :: lw_albedo
273
274	! Direct and diffuse shortwave surface albedo in each shortwave
275	! g-point; note that these are weighted averages of the values
276	! from individual tiles
277	real(jprb), dimension(config%n_g_sw, istartcol:iendcol) :: sw_albedo_direct
278	real(jprb), dimension(config%n_g_sw, istartcol:iendcol) :: sw_albedo_diffuse
279
280	! The incoming shortwave flux into a plane perpendicular to the
281	! incoming radiation at top-of-atmosphere in each of the shortwave
282	! g-points
283	real(jprb), dimension(config%n_g_sw,istartcol:iendcol) :: incoming_sw
284
285	character(len=100) :: rad_prop_file_name
286	character(*), parameter :: rad_prop_base_file_name = "radiative_properties"
287
288	real(jprb) :: hook_handle
289
290	if (lhook) call dr_hook('radiation_interface:radiation',0,hook_handle)
291
292	if (thermodynamics%pressure_hl(istartcol,2) &
293	& < thermodynamics%pressure_hl(istartcol,1)) then
294	! Input arrays are arranged in order of decreasing pressure /
295	! increasing height: the following subroutine reverses them,
296	! call the radiation scheme and then reverses the returned
297	! fluxes
298	call radiation_reverse(ncol, nlev, istartcol, iendcol, config, &
299	& single_level, thermodynamics, gas, cloud, aerosol, flux)
300	else
301
302	! Input arrays arranged in order of increasing pressure /
303	! decreasing height: progress normally
304
305	! Extract surface albedos at each gridpoint
306	call single_level%get_albedos(istartcol, iendcol, config, &
307	& sw_albedo_direct, sw_albedo_diffuse, &
308	& lw_albedo)
309
310	! Compute gas absorption optical depth in shortwave and
311	! longwave, shortwave single scattering albedo (i.e. fraction of
312	! extinction due to Rayleigh scattering), Planck functions and
313	! incoming shortwave flux at each g-point, for the specified
314	! range of atmospheric columns
315	if (config%i_gas_model == IGasModelMonochromatic) then
316	call gas_optics_mono(ncol,nlev,istartcol,iendcol, config, &
317	& single_level, thermodynamics, gas, lw_albedo, &
318	& od_lw, od_sw, ssa_sw, &
319	& planck_hl, lw_emission, incoming_sw)
320	else if (config%i_gas_model == IGasModelIFSRRTMG) then
321	call gas_optics_rrtmg(ncol,nlev,istartcol,iendcol, config, &
322	& single_level, thermodynamics, gas, &
323	& od_lw, od_sw, ssa_sw, lw_albedo=lw_albedo, &
324	& planck_hl=planck_hl, lw_emission=lw_emission, &
325	& incoming_sw=incoming_sw)
326	else
327	call gas_optics_ecckd(ncol,nlev,istartcol,iendcol, config, &
328	& single_level, thermodynamics, gas, &
329	& od_lw, od_sw, ssa_sw, lw_albedo=lw_albedo, &
330	& planck_hl=planck_hl, lw_emission=lw_emission, &
331	& incoming_sw=incoming_sw)
332	end if
333
334	if (config%do_clouds) then
335	! Crop the cloud fraction to remove clouds that have too small
336	! a fraction or water content; after this, we can safely
337	! assume that a cloud is present if cloud%fraction > 0.0.
338	call cloud%crop_cloud_fraction(istartcol, iendcol, &
339	& config%cloud_fraction_threshold, &
340	& config%cloud_mixing_ratio_threshold)
341
342	! Compute hydrometeor absorption/scattering properties in each
343	! shortwave and longwave band
344	if (config%i_gas_model == IGasModelMonochromatic) then
345	call cloud_optics_mono(nlev, istartcol, iendcol, &
346	& config, thermodynamics, cloud, &
347	& od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
348	& od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
349	elseif (config%use_general_cloud_optics) then
350	call general_cloud_optics(nlev, istartcol, iendcol, &
351	& config, thermodynamics, cloud, &
352	& od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
353	& od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
354	else
355	call cloud_optics(nlev, istartcol, iendcol, &
356	& config, thermodynamics, cloud, &
357	& od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
358	& od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
359	end if
360	end if ! do_clouds
361
362	if (config%use_aerosols) then
363	if (config%i_gas_model == IGasModelMonochromatic) then
364	! call add_aerosol_optics_mono(nlev,istartcol,iendcol, &
365	! & config, thermodynamics, gas, aerosol, &
366	! & od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw)
367	else
368	call add_aerosol_optics(nlev,istartcol,iendcol, &
369	& config, thermodynamics, gas, aerosol, &
370	& od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw)
371	end if
372	else
373	g_sw(:,:,istartcol:iendcol) = 0.0_jprb
374	if (config%do_lw_aerosol_scattering) then
375	ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb
376	g_lw(:,:,istartcol:iendcol) = 0.0_jprb
377	end if
378	end if
379
380	! For diagnostic purposes, save these intermediate variables to
381	! a NetCDF file
382	if (config%do_save_radiative_properties) then
383	if (istartcol == 1 .and. iendcol == ncol) then
384	rad_prop_file_name = rad_prop_base_file_name // ".nc"
385	else
386	write(rad_prop_file_name,'(a,a,i4.4,a,i4.4,a)') &
387	& rad_prop_base_file_name, '_', istartcol, '-',iendcol,'.nc'
388	end if
389	call save_radiative_properties(trim(rad_prop_file_name), &
390	& nlev, istartcol, iendcol, &
391	& config, single_level, thermodynamics, cloud, &
392	& planck_hl, lw_emission, lw_albedo, &
393	& sw_albedo_direct, sw_albedo_diffuse, incoming_sw, &
394	& od_lw, ssa_lw, g_lw, od_sw, ssa_sw, g_sw, &
395	& od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
396	& od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
397	end if
398
399	if (config%do_lw) then
400	if (config%iverbose >= 2) then
401	write(nulout,'(a)') 'Computing longwave fluxes'
402	end if
403
404	if (config%i_solver_lw == ISolverMcICA) then
405	! Compute fluxes using the McICA longwave solver
406	call solver_mcica_lw(nlev,istartcol,iendcol, &
407	& config, single_level, cloud, &
408	& od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, &
409	& g_lw_cloud, planck_hl, lw_emission, lw_albedo, flux)
410	else if (config%i_solver_lw == ISolverSPARTACUS) then
411	! Compute fluxes using the SPARTACUS longwave solver
412	call solver_spartacus_lw(nlev,istartcol,iendcol, &
413	& config, thermodynamics, cloud, &
414	& od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
415	& planck_hl, lw_emission, lw_albedo, flux)
416	else if (config%i_solver_lw == ISolverTripleclouds) then
417	! Compute fluxes using the Tripleclouds longwave solver
418	call solver_tripleclouds_lw(nlev,istartcol,iendcol, &
419	& config, cloud, &
420	& od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
421	& planck_hl, lw_emission, lw_albedo, flux)
422	elseif (config%i_solver_lw == ISolverHomogeneous) then
423	! Compute fluxes using the homogeneous solver
424	call solver_homogeneous_lw(nlev,istartcol,iendcol, &
425	& config, cloud, &
426	& od_lw, ssa_lw, g_lw, od_lw_cloud, ssa_lw_cloud, &
427	& g_lw_cloud, planck_hl, lw_emission, lw_albedo, flux)
428	else
429	! Compute fluxes using the cloudless solver
430	call solver_cloudless_lw(nlev,istartcol,iendcol, &
431	& config, od_lw, ssa_lw, g_lw, &
432	& planck_hl, lw_emission, lw_albedo, flux)
433	end if
434	end if
435
436	if (config%do_sw) then
437	if (config%iverbose >= 2) then
438	write(nulout,'(a)') 'Computing shortwave fluxes'
439	end if
440
441	if (config%i_solver_sw == ISolverMcICA) then
442	! Compute fluxes using the McICA shortwave solver
443	call solver_mcica_sw(nlev,istartcol,iendcol, &
444	& config, single_level, cloud, &
445	& od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, &
446	& g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, &
447	& incoming_sw, flux)
448	else if (config%i_solver_sw == ISolverSPARTACUS) then
449	! Compute fluxes using the SPARTACUS shortwave solver
450	call solver_spartacus_sw(nlev,istartcol,iendcol, &
451	& config, single_level, thermodynamics, cloud, &
452	& od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, &
453	& g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, &
454	& incoming_sw, flux)
455	else if (config%i_solver_sw == ISolverTripleclouds) then
456	! Compute fluxes using the Tripleclouds shortwave solver
457	call solver_tripleclouds_sw(nlev,istartcol,iendcol, &
458	& config, single_level, cloud, &
459	& od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, &
460	& g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, &
461	& incoming_sw, flux)
462	elseif (config%i_solver_sw == ISolverHomogeneous) then
463	! Compute fluxes using the homogeneous solver
464	call solver_homogeneous_sw(nlev,istartcol,iendcol, &
465	& config, single_level, cloud, &
466	& od_sw, ssa_sw, g_sw, od_sw_cloud, ssa_sw_cloud, &
467	& g_sw_cloud, sw_albedo_direct, sw_albedo_diffuse, &
468	& incoming_sw, flux)
469	else
470	! Compute fluxes using the cloudless solver
471	call solver_cloudless_sw(nlev,istartcol,iendcol, &
472	& config, single_level, od_sw, ssa_sw, g_sw, &
473	& sw_albedo_direct, sw_albedo_diffuse, &
474	& incoming_sw, flux)
475	end if
476	end if
477
478	! Store surface downwelling fluxes in bands from fluxes in g
479	! points
480	call flux%calc_surface_spectral(config, istartcol, iendcol)
481
482	end if
483
484	if (lhook) call dr_hook('radiation_interface:radiation',1,hook_handle)
485
486	end subroutine radiation
487
488
489	!---------------------------------------------------------------------
490	! If the input arrays are arranged in order of decreasing pressure /
491	! increasing height then this subroutine reverses them, calls the
492	! radiation scheme and then reverses the returned fluxes. Since this
493	! subroutine calls, and is called by "radiation", it must be in this
494	! module to avoid circular dependencies.
495	subroutine radiation_reverse(ncol, nlev, istartcol, iendcol, config, &
496	& single_level, thermodynamics, gas, cloud, aerosol, flux)
497
498	use parkind1, only : jprb
499
500	use radiation_io, only : nulout
501	use radiation_config, only : config_type
502	use radiation_single_level, only : single_level_type
503	use radiation_thermodynamics, only : thermodynamics_type
504	use radiation_gas, only : gas_type
505	use radiation_cloud, only : cloud_type
506	use radiation_aerosol, only : aerosol_type
507	use radiation_flux, only : flux_type
508
509	! Inputs
510	integer, intent(in) :: ncol ! number of columns
511	integer, intent(in) :: nlev ! number of model levels
512	integer, intent(in) :: istartcol, iendcol ! range of columns to process
513	type(config_type), intent(in) :: config
514	type(single_level_type), intent(in) :: single_level
515	type(thermodynamics_type),intent(in) :: thermodynamics
516	type(gas_type), intent(in) :: gas
517	type(cloud_type), intent(in) :: cloud
518	type(aerosol_type), intent(in) :: aerosol
519	! Output
520	type(flux_type), intent(inout):: flux
521
522	! Reversed data structures
523	type(thermodynamics_type) :: thermodynamics_rev
524	type(gas_type) :: gas_rev
525	type(cloud_type) :: cloud_rev
526	type(aerosol_type) :: aerosol_rev
527	type(flux_type) :: flux_rev
528
529	! Start and end levels for aerosol data
530	integer :: istartlev, iendlev
531
532	if (config%iverbose >= 2) then
533	write(nulout,'(a)') 'Reversing arrays to be in order of increasing pressure'
534	end if
535
536	! Allocate reversed arrays
537	call thermodynamics_rev%allocate(ncol, nlev)
538	call cloud_rev%allocate(ncol, nlev)
539	call flux_rev%allocate(config, istartcol, iendcol, nlev)
540	if (allocated(aerosol%mixing_ratio)) then
541	istartlev = nlev + 1 - aerosol%iendlev
542	iendlev = nlev + 1 - aerosol%istartlev
543	call aerosol_rev%allocate(ncol, istartlev, iendlev, &
544	& config%n_aerosol_types)
545	end if
546
547	! Fill reversed thermodynamic arrays
548	thermodynamics_rev%pressure_hl(istartcol:iendcol,:) &
549	& = thermodynamics%pressure_hl(istartcol:iendcol, nlev+1:1:-1)
550	thermodynamics_rev%temperature_hl(istartcol:iendcol,:) &
551	& = thermodynamics%temperature_hl(istartcol:iendcol, nlev+1:1:-1)
552
553	! Fill reversed gas arrays
554	call gas%reverse(istartcol, iendcol, gas_rev)
555
556	if (config%do_clouds) then
557	! Fill reversed cloud arrays
558	cloud_rev%q_liq(istartcol:iendcol,:) &
559	& = cloud%q_liq(istartcol:iendcol,nlev:1:-1)
560	cloud_rev%re_liq(istartcol:iendcol,:) &
561	& = cloud%re_liq(istartcol:iendcol,nlev:1:-1)
562	cloud_rev%q_ice(istartcol:iendcol,:) &
563	& = cloud%q_ice(istartcol:iendcol,nlev:1:-1)
564	cloud_rev%re_ice(istartcol:iendcol,:) &
565	& = cloud%re_ice(istartcol:iendcol,nlev:1:-1)
566	cloud_rev%fraction(istartcol:iendcol,:) &
567	& = cloud%fraction(istartcol:iendcol,nlev:1:-1)
568	cloud_rev%overlap_param(istartcol:iendcol,:) &
569	& = cloud%overlap_param(istartcol:iendcol,nlev-1:1:-1)
570	if (allocated(cloud%fractional_std)) then
571	cloud_rev%fractional_std(istartcol:iendcol,:) &
572	& = cloud%fractional_std(istartcol:iendcol,nlev:1:-1)
573	else
574	cloud_rev%fractional_std(istartcol:iendcol,:) = 0.0_jprb
575	end if
576	if (allocated(cloud%inv_cloud_effective_size)) then
577	cloud_rev%inv_cloud_effective_size(istartcol:iendcol,:) &
578	& = cloud%inv_cloud_effective_size(istartcol:iendcol,nlev:1:-1)
579	else
580	cloud_rev%inv_cloud_effective_size(istartcol:iendcol,:) = 0.0_jprb
581	end if
582	end if
583
584	if (allocated(aerosol%mixing_ratio)) then
585	aerosol_rev%mixing_ratio(:,istartlev:iendlev,:) &
586	& = aerosol%mixing_ratio(:,aerosol%iendlev:aerosol%istartlev:-1,:)
587	end if
588
589	! Run radiation scheme on reversed profiles
590	call radiation(ncol, nlev,istartcol,iendcol, &
591	& config, single_level, thermodynamics_rev, gas_rev, &
592	& cloud_rev, aerosol_rev, flux_rev)
593
594	! Reorder fluxes
595	if (allocated(flux%lw_up)) then
596	flux%lw_up(istartcol:iendcol,:) &
597	& = flux_rev%lw_up(istartcol:iendcol,nlev+1:1:-1)
598	flux%lw_dn(istartcol:iendcol,:) &
599	& = flux_rev%lw_dn(istartcol:iendcol,nlev+1:1:-1)
600	if (allocated(flux%lw_up_clear)) then
601	flux%lw_up_clear(istartcol:iendcol,:) &
602	& = flux_rev%lw_up_clear(istartcol:iendcol,nlev+1:1:-1)
603	flux%lw_dn_clear(istartcol:iendcol,:) &
604	& = flux_rev%lw_dn_clear(istartcol:iendcol,nlev+1:1:-1)
605	end if
606	end if
607	if (allocated(flux%sw_up)) then
608	flux%sw_up(istartcol:iendcol,:) &
609	& = flux_rev%sw_up(istartcol:iendcol,nlev+1:1:-1)
610	flux%sw_dn(istartcol:iendcol,:) &
611	& = flux_rev%sw_dn(istartcol:iendcol,nlev+1:1:-1)
612	if (allocated(flux%sw_dn_direct)) then
613	flux%sw_dn_direct(istartcol:iendcol,:) &
614	& = flux_rev%sw_dn_direct(istartcol:iendcol,nlev+1:1:-1)
615	end if
616	if (allocated(flux%sw_up_clear)) then
617	flux%sw_up_clear(istartcol:iendcol,:) &
618	& = flux_rev%sw_up_clear(istartcol:iendcol,nlev+1:1:-1)
619	flux%sw_dn_clear(istartcol:iendcol,:) &
620	& = flux_rev%sw_dn_clear(istartcol:iendcol,nlev+1:1:-1)
621	if (allocated(flux%sw_dn_direct_clear)) then
622	flux%sw_dn_direct_clear(istartcol:iendcol,:) &
623	& = flux_rev%sw_dn_direct_clear(istartcol:iendcol,nlev+1:1:-1)
624	end if
625	end if
626	end if
627
628	! Deallocate reversed arrays
629	call thermodynamics_rev%deallocate
630	call gas_rev%deallocate
631	call cloud_rev%deallocate
632	call flux_rev%deallocate
633	if (allocated(aerosol%mixing_ratio)) then
634	call aerosol_rev%deallocate
635	end if
636
637	end subroutine radiation_reverse
638
639	end module radiation_interface

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

Download in other formats:

Original Format