Home

Context Navigation

radiation_model_mod.f90 @ 4429

Last change on this file since 4429 was 4429, checked in by raasch, 5 years ago

serial (non-MPI) test case added, several bugfixes for the serial mode

Property svn:keywords set to Id

Property svn:mergeinfo set to (toggle deleted branches)

/palm/branches/chemistry/SOURCE/radiation_model_mod.f90	2047-3190,3218-3297
/palm/branches/forwind/SOURCE/radiation_model_mod.f90	1564-1913
/palm/branches/mosaik_M2/radiation_model_mod.f90	2360-3471
/palm/branches/palm4u/SOURCE/radiation_model_mod.f90	2540-2692
/palm/branches/radiation/SOURCE/radiation_model_mod.f90	2081-3493
/palm/branches/rans/SOURCE/radiation_model_mod.f90	2078-3128
/palm/branches/resler/SOURCE/radiation_model_mod.f90	2023-4391
/palm/branches/salsa/SOURCE/radiation_model_mod.f90	2503-3460
/palm/branches/fricke/SOURCE/radiation_model_mod.f90	942-977
/palm/branches/hoffmann/SOURCE/radiation_model_mod.f90	989-1052
/palm/branches/letzel/masked_output/SOURCE/radiation_model_mod.f90	296-409
/palm/branches/suehring/radiation_model_mod.f90	423-666

File size: 555.3 KB

Line
1	!> @file radiation_model_mod.f90
2	!------------------------------------------------------------------------------!
3	! This file is part of the PALM model system.
4	!
5	! PALM is free software: you can redistribute it and/or modify it under the
6	! terms of the GNU General Public License as published by the Free Software
7	! Foundation, either version 3 of the License, or (at your option) any later
8	! version.
9	!
10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
13	!
14	! You should have received a copy of the GNU General Public License along with
15	! PALM. If not, see <http://www.gnu.org/licenses/>.
16	!
17	! Copyright 2015-2020 Institute of Computer Science of the
18	! Czech Academy of Sciences, Prague
19	! Copyright 2015-2019 Czech Technical University in Prague
20	! Copyright 1997-2020 Leibniz Universitaet Hannover
21	!------------------------------------------------------------------------------!
22	!
23	! Current revisions:
24	! ------------------
25	!
26	!
27	! Former revisions:
28	! -----------------
29	! $Id: radiation_model_mod.f90 4429 2020-02-27 15:24:30Z raasch $
30	! bugfixes: cpp-directives for serial mode moved, small changes to get serial mode compiled
31	!
32	! 4400 2020-02-10 20:32:41Z suehring
33	! Initialize radiation arrays with zero
34	!
35	! 4392 2020-01-31 16:14:57Z pavelkrc
36	! - Add debug tracing of large radiative fluxes (option trace_fluxes_above)
37	! - Print exact counts of SVF and CSF if debut_output is enabled
38	! - Update descriptions of RTM 3.0 and related comments
39	!
40	! 4360 2020-01-07 11:25:50Z suehring
41	! Renamed pc_heating_rate, pc_transpiration_rate, pc_transpiration_rate to
42	! pcm_heating_rate, pcm_latent_rate, pcm_transpiration_rate
43	!
44	! 4340 2019-12-16 08:17:03Z Giersch
45	! Albedo indices for building_surface_pars are now declared as parameters to
46	! prevent an error if the gfortran compiler with -Werror=unused-value is used
47	!
48	! 4291 2019-11-11 12:36:54Z moh.hefny
49	! Enabled RTM in case of biometeorology even if there is no vertical
50	! surfaces or 3D vegetation in the domain
51	!
52	! 4286 2019-10-30 16:01:14Z resler
53	! - Fix wrong treating of time_rad during interpolation in radiation_model_mod
54	! - Fix wrong checks of time_rad from dynamic driver in radiation_model_mod
55	! - Add new directional model of human body for MRT: ellipsoid
56	!
57	! 4271 2019-10-23 10:46:41Z maronga
58	! Bugfix: missing parentheses in calculation of snow albedo
59	!
60	! 4245 2019-09-30 08:40:37Z pavelkrc
61	! Initialize explicit per-surface albedos from building_surface_pars
62	!
63	! 4238 2019-09-25 16:06:01Z suehring
64	! Modify check in order to avoid equality comparisons of floating points
65	!
66	! 4227 2019-09-10 18:04:34Z gronemeier
67	! implement new palm_date_time_mod
68	!
69	! 4226 2019-09-10 17:03:24Z suehring
70	! - Netcdf input routine for dimension length renamed
71	! - Define time variable for external radiation input relative to time_utc_init
72	!
73	! 4210 2019-09-02 13:07:09Z suehring
74	! - Revise steering of splitting diffuse and direct radiation
75	! - Bugfixes in checks
76	! - Optimize mapping of radiation components onto 2D arrays, avoid unnecessary
77	! operations
78	!
79	! 4208 2019-09-02 09:01:07Z suehring
80	! Bugfix in accessing albedo_pars in the clear-sky branch
81	! (merge from branch resler)
82	!
83	! 4198 2019-08-29 15:17:48Z gronemeier
84	! Prohibit execution of radiation model if rotation_angle is not zero
85	!
86	! 4197 2019-08-29 14:33:32Z suehring
87	! Revise steering of surface albedo initialization when albedo_pars is provided
88	!
89	! 4190 2019-08-27 15:42:37Z suehring
90	! Implement external radiation forcing also for level-of-detail = 2
91	! (horizontally 2D radiation)
92	!
93	! 4188 2019-08-26 14:15:47Z suehring
94	! Minor adjustment in error message
95	!
96	! 4187 2019-08-26 12:43:15Z suehring
97	! - Take external radiation from root domain dynamic input if not provided for
98	! each nested domain
99	! - Combine MPI_ALLREDUCE calls to reduce mpi overhead
100	!
101	! 4182 2019-08-22 15:20:23Z scharf
102	! Corrected "Former revisions" section
103	!
104	! 4179 2019-08-21 11:16:12Z suehring
105	! Remove debug prints
106	!
107	! 4178 2019-08-21 11:13:06Z suehring
108	! External radiation forcing implemented.
109	!
110	! 4168 2019-08-16 13:50:17Z suehring
111	! Replace function get_topography_top_index by topo_top_ind
112	!
113	! 4157 2019-08-14 09:19:12Z suehring
114	! Give informative message on raytracing distance only by core zero
115	!
116	! 4148 2019-08-08 11:26:00Z suehring
117	! Comments added
118	!
119	! 4134 2019-08-02 18:39:57Z suehring
120	! Bugfix in formatted write statement
121	!
122	! 4127 2019-07-30 14:47:10Z suehring
123	! Remove unused pch_index (merge from branch resler)
124	!
125	! 4089 2019-07-11 14:30:27Z suehring
126	! - Correct level 2 initialization of spectral albedos in rrtmg branch, long- and
127	! shortwave albedos were mixed-up.
128	! - Change order of albedo_pars so that it is now consistent with the defined
129	! order of albedo_pars in PIDS
130	!
131	! 4069 2019-07-01 14:05:51Z Giersch
132	! Masked output running index mid has been introduced as a local variable to
133	! avoid runtime error (Loop variable has been modified) in time_integration
134	!
135	! 4067 2019-07-01 13:29:25Z suehring
136	! Bugfix, pass dummy string to MPI_INFO_SET (J. Resler)
137	!
138	! 4039 2019-06-18 10:32:41Z suehring
139	! Bugfix for masked data output
140	!
141	! 4008 2019-05-30 09:50:11Z moh.hefny
142	! Bugfix in check variable when a variable's string is less than 3
143	! characters is processed. All variables now are checked if they
144	! belong to radiation
145	!
146	! 3992 2019-05-22 16:49:38Z suehring
147	! Bugfix in rrtmg radiation branch in a nested run when the lowest prognistic
148	! grid points in a child domain are all inside topography
149	!
150	! 3987 2019-05-22 09:52:13Z kanani
151	! Introduce alternative switch for debug output during timestepping
152	!
153	! 3943 2019-05-02 09:50:41Z maronga
154	! Missing blank characteer added.
155	!
156	! 3900 2019-04-16 15:17:43Z suehring
157	! Fixed initialization problem
158	!
159	! 3885 2019-04-11 11:29:34Z kanani
160	! Changes related to global restructuring of location messages and introduction
161	! of additional debug messages
162	!
163	! 3881 2019-04-10 09:31:22Z suehring
164	! Output of albedo and emissivity moved from USM, bugfixes in initialization
165	! of albedo
166	!
167	! 3861 2019-04-04 06:27:41Z maronga
168	! Bugfix: factor of 4.0 required instead of 3.0 in calculation of rad_lw_out_change_0
169	!
170	! 3859 2019-04-03 20:30:31Z maronga
171	! Added some descriptions
172	!
173	! 3847 2019-04-01 14:51:44Z suehring
174	! Implement check for dt_radiation (must be > 0)
175	!
176	! 3846 2019-04-01 13:55:30Z suehring
177	! unused variable removed
178	!
179	! 3814 2019-03-26 08:40:31Z pavelkrc
180	! Change zenith(0:0) and others to scalar.
181	! Code review.
182	! Rename exported nzu, nzp and related variables due to name conflict
183	!
184	! 3771 2019-02-28 12:19:33Z raasch
185	! rrtmg preprocessor for directives moved/added, save attribute added to temporary
186	! pointers to avoid compiler warnings about outlived pointer targets,
187	! statement added to avoid compiler warning about unused variable
188	!
189	! 3769 2019-02-28 10:16:49Z moh.hefny
190	! removed unused variables and subroutine radiation_radflux_gridbox
191	!
192	! 3767 2019-02-27 08:18:02Z raasch
193	! unused variable for file index removed from rrd-subroutines parameter list
194	!
195	! 3760 2019-02-21 18:47:35Z moh.hefny
196	! Bugfix: initialized simulated_time before calculating solar position
197	! to enable restart option with reading in SVF from file(s).
198	!
199	! 3754 2019-02-19 17:02:26Z kanani
200	! (resler, pavelkrc)
201	! Bugfixes: add further required MRT factors to read/write_svf,
202	! fix for aggregating view factors to eliminate local noise in reflected
203	! irradiance at mutually close surfaces (corners, presence of trees) in the
204	! angular discretization scheme.
205	!
206	! 3752 2019-02-19 09:37:22Z resler
207	! added read/write number of MRT factors to the respective routines
208	!
209	! 3705 2019-01-29 19:56:39Z suehring
210	! Make variables that are sampled in virtual measurement module public
211	!
212	! 3704 2019-01-29 19:51:41Z suehring
213	! Some interface calls moved to module_interface + cleanup
214	!
215	! 3667 2019-01-10 14:26:24Z schwenkel
216	! Modified check for rrtmg input files
217	!
218	! 3655 2019-01-07 16:51:22Z knoop
219	! nopointer option removed
220	!
221	! 1496 2014-12-02 17:25:50Z maronga
222	! Initial revision
223	!
224	!
225	! Description:
226	! ------------
227	!> Radiation models and interfaces:
228	!> constant, simple and RRTMG models, interface to external radiation model
229	!> Radiative Transfer Model (RTM) version 3.0 for modelling of radiation
230	!> interactions within urban canopy or other surface layer in complex terrain
231	!> Integrations of RTM with other PALM-4U modules:
232	!> integration with RRTMG, USM, LSM, PCM, BIO modules
233	!>
234	!> @todo move variable definitions used in radiation_init only to the subroutine
235	!> as they are no longer required after initialization.
236	!> @todo Output of full column vertical profiles used in RRTMG
237	!> @todo Output of other rrtm arrays (such as volume mixing ratios)
238	!> @todo Optimize radiation_tendency routines
239	!>
240	!> @note Many variables have a leading dummy dimension (0:0) in order to
241	!> match the assume-size shape expected by the RRTMG model.
242	!------------------------------------------------------------------------------!
243	MODULE radiation_model_mod
244
245	USE arrays_3d, &
246	ONLY: dzw, hyp, nc, pt, p, q, ql, u, v, w, zu, zw, exner, d_exner
247
248	USE basic_constants_and_equations_mod, &
249	ONLY: c_p, g, lv_d_cp, l_v, pi, r_d, rho_l, solar_constant, sigma_sb, &
250	barometric_formula
251
252	USE calc_mean_profile_mod, &
253	ONLY: calc_mean_profile
254
255	USE control_parameters, &
256	ONLY: biometeorology, cloud_droplets, coupling_char, &
257	debug_output, debug_output_timestep, debug_string, &
258	dt_3d, &
259	dz, dt_spinup, end_time, &
260	humidity, &
261	initializing_actions, io_blocks, io_group, &
262	land_surface, large_scale_forcing, &
263	latitude, longitude, lsf_surf, &
264	message_string, plant_canopy, pt_surface, &
265	rho_surface, simulated_time, spinup_time, surface_pressure, &
266	read_svf, write_svf, &
267	time_since_reference_point, urban_surface, varnamelength
268
269	USE cpulog, &
270	ONLY: cpu_log, log_point, log_point_s
271
272	USE grid_variables, &
273	ONLY: ddx, ddy, dx, dy
274
275	USE indices, &
276	ONLY: nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, &
277	nzb, nzt, topo_top_ind
278
279	USE, INTRINSIC :: iso_c_binding
280
281	USE kinds
282
283	USE bulk_cloud_model_mod, &
284	ONLY: bulk_cloud_model, microphysics_morrison, na_init, nc_const, sigma_gc
285
286	#if defined ( __netcdf )
287	USE NETCDF
288	#endif
289
290	USE netcdf_data_input_mod, &
291	ONLY: albedo_type_f, &
292	albedo_pars_f, &
293	building_type_f, &
294	building_surface_pars_f, &
295	pavement_type_f, &
296	vegetation_type_f, &
297	water_type_f, &
298	char_fill, &
299	char_lod, &
300	check_existence, &
301	close_input_file, &
302	get_attribute, &
303	get_dimension_length, &
304	get_variable, &
305	inquire_num_variables, &
306	inquire_variable_names, &
307	input_file_dynamic, &
308	input_pids_dynamic, &
309	num_var_pids, &
310	pids_id, &
311	open_read_file, &
312	real_1d_3d, &
313	vars_pids
314
315	USE palm_date_time_mod, &
316	ONLY: date_time_str_len, get_date_time, &
317	hours_per_day, seconds_per_hour
318
319	USE plant_canopy_model_mod, &
320	ONLY: lad_s, &
321	pcm_heating_rate, &
322	pcm_transpiration_rate, &
323	pcm_latent_rate, &
324	plant_canopy_transpiration, &
325	pcm_calc_transpiration_rate
326
327	USE pegrid
328
329	#if defined ( __rrtmg )
330	USE parrrsw, &
331	ONLY: naerec, nbndsw
332
333	USE parrrtm, &
334	ONLY: nbndlw
335
336	USE rrtmg_lw_init, &
337	ONLY: rrtmg_lw_ini
338
339	USE rrtmg_sw_init, &
340	ONLY: rrtmg_sw_ini
341
342	USE rrtmg_lw_rad, &
343	ONLY: rrtmg_lw
344
345	USE rrtmg_sw_rad, &
346	ONLY: rrtmg_sw
347	#endif
348	USE statistics, &
349	ONLY: hom
350
351	USE surface_mod, &
352	ONLY: ind_pav_green, ind_veg_wall, ind_wat_win, &
353	surf_lsm_h, surf_lsm_v, surf_type, surf_usm_h, surf_usm_v, &
354	vertical_surfaces_exist
355
356	IMPLICIT NONE
357
358	CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg'
359
360	!
361	!-- Predefined Land surface classes (albedo_type) after Briegleb (1992)
362	CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/ &
363	'user defined ', & ! 0
364	'ocean ', & ! 1
365	'mixed farming, tall grassland ', & ! 2
366	'tall/medium grassland ', & ! 3
367	'evergreen shrubland ', & ! 4
368	'short grassland/meadow/shrubland ', & ! 5
369	'evergreen needleleaf forest ', & ! 6
370	'mixed deciduous evergreen forest ', & ! 7
371	'deciduous forest ', & ! 8
372	'tropical evergreen broadleaved forest', & ! 9
373	'medium/tall grassland/woodland ', & ! 10
374	'desert, sandy ', & ! 11
375	'desert, rocky ', & ! 12
376	'tundra ', & ! 13
377	'land ice ', & ! 14
378	'sea ice ', & ! 15
379	'snow ', & ! 16
380	'bare soil ', & ! 17
381	'asphalt/concrete mix ', & ! 18
382	'asphalt (asphalt concrete) ', & ! 19
383	'concrete (Portland concrete) ', & ! 20
384	'sett ', & ! 21
385	'paving stones ', & ! 22
386	'cobblestone ', & ! 23
387	'metal ', & ! 24
388	'wood ', & ! 25
389	'gravel ', & ! 26
390	'fine gravel ', & ! 27
391	'pebblestone ', & ! 28
392	'woodchips ', & ! 29
393	'tartan (sports) ', & ! 30
394	'artifical turf (sports) ', & ! 31
395	'clay (sports) ', & ! 32
396	'building (dummy) ' & ! 33
397	/)
398	!
399	!-- Indices of radiation-related input attributes in building_surface_pars
400	!-- (other are in urban_surface_mod)
401	INTEGER(iwp), PARAMETER :: ind_s_alb_b_wall = 19 !< index for Broadband albedo of wall fraction
402	INTEGER(iwp), PARAMETER :: ind_s_alb_l_wall = 20 !< index for Longwave albedo of wall fraction
403	INTEGER(iwp), PARAMETER :: ind_s_alb_s_wall = 21 !< index for Shortwave albedo of wall fraction
404	INTEGER(iwp), PARAMETER :: ind_s_alb_b_win = 22 !< index for Broadband albedo of window fraction
405	INTEGER(iwp), PARAMETER :: ind_s_alb_l_win = 23 !< index for Longwave albedo of window fraction
406	INTEGER(iwp), PARAMETER :: ind_s_alb_s_win = 24 !< index for Shortwave albedo of window fraction
407	INTEGER(iwp), PARAMETER :: ind_s_alb_b_green = 24 !< index for Broadband albedo of green fraction
408	INTEGER(iwp), PARAMETER :: ind_s_alb_l_green = 25 !< index for Longwave albedo of green fraction
409	INTEGER(iwp), PARAMETER :: ind_s_alb_s_green = 26 !< index for Shortwave albedo of green fraction
410
411	INTEGER(iwp) :: albedo_type = 9999999_iwp, & !< Albedo surface type
412	dots_rad = 0_iwp !< starting index for timeseries output
413
414	LOGICAL :: unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed
415	constant_albedo = .FALSE., & !< flag parameter indicating whether the albedo may change depending on zenith
416	force_radiation_call = .FALSE., & !< flag parameter for unscheduled radiation calls
417	lw_radiation = .TRUE., & !< flag parameter indicating whether longwave radiation shall be calculated
418	radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used
419	sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down
420	sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be calculated
421	sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated
422	average_radiation = .FALSE., & !< flag to set the calculation of radiation averaging for the domain
423	radiation_interactions = .FALSE., & !< flag to activiate RTM (TRUE only if vertical urban/land surface and trees exist)
424	surface_reflections = .TRUE., & !< flag to switch the calculation of radiation interaction between surfaces.
425	!< When it switched off, only the effect of buildings and trees shadow
426	!< will be considered. However fewer SVFs are expected.
427	radiation_interactions_on = .TRUE. !< namelist flag to force RTM activiation regardless to vertical urban/land surface and trees
428
429	REAL(wp) :: albedo = 9999999.9_wp, & !< NAMELIST alpha
430	albedo_lw_dif = 9999999.9_wp, & !< NAMELIST aldif
431	albedo_lw_dir = 9999999.9_wp, & !< NAMELIST aldir
432	albedo_sw_dif = 9999999.9_wp, & !< NAMELIST asdif
433	albedo_sw_dir = 9999999.9_wp, & !< NAMELIST asdir
434	decl_1, & !< declination coef. 1
435	decl_2, & !< declination coef. 2
436	decl_3, & !< declination coef. 3
437	dt_radiation = 0.0_wp, & !< radiation model timestep
438	emissivity = 9999999.9_wp, & !< NAMELIST surface emissivity
439	lon = 0.0_wp, & !< longitude in radians
440	lat = 0.0_wp, & !< latitude in radians
441	net_radiation = 0.0_wp, & !< net radiation at surface
442	skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time
443	sky_trans, & !< sky transmissivity
444	time_radiation = 0.0_wp, & !< time since last call of radiation code
445	trace_fluxes_above = -1.0_wp !< NAMELIST option for debug tracing of large radiative fluxes (W/m2;W/m3)
446
447	INTEGER(iwp) :: day_of_year !< day of the current year
448
449	REAL(wp) :: cos_zenith !< cosine of solar zenith angle, also z-coordinate of solar unit vector
450	REAL(wp) :: d_hours_day !< 1 / hours-per-day
451	REAL(wp) :: d_seconds_hour !< 1 / seconds-per-hour
452	REAL(wp) :: second_of_day !< second of the current day
453	REAL(wp) :: sun_dir_lat !< y-coordinate of solar unit vector
454	REAL(wp) :: sun_dir_lon !< x-coordinate of solar unit vector
455
456	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of net radiation (rad_net) at surface
457	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_xy_av !< average of incoming longwave radiation at surface
458	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_out_xy_av !< average of outgoing longwave radiation at surface
459	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_xy_av !< average of incoming shortwave radiation at surface
460	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_out_xy_av !< average of outgoing shortwave radiation at surface
461
462	REAL(wp), PARAMETER :: emissivity_atm_clsky = 0.8_wp !< emissivity of the clear-sky atmosphere
463	!
464	!-- Land surface albedos for solar zenith angle of 60degree after Briegleb (1992)
465	!-- (broadband, longwave, shortwave ): bb, lw, sw,
466	REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/&
467	0.06_wp, 0.06_wp, 0.06_wp, & ! 1
468	0.19_wp, 0.28_wp, 0.09_wp, & ! 2
469	0.23_wp, 0.33_wp, 0.11_wp, & ! 3
470	0.23_wp, 0.33_wp, 0.11_wp, & ! 4
471	0.25_wp, 0.34_wp, 0.14_wp, & ! 5
472	0.14_wp, 0.22_wp, 0.06_wp, & ! 6
473	0.17_wp, 0.27_wp, 0.06_wp, & ! 7
474	0.19_wp, 0.31_wp, 0.06_wp, & ! 8
475	0.14_wp, 0.22_wp, 0.06_wp, & ! 9
476	0.18_wp, 0.28_wp, 0.06_wp, & ! 10
477	0.43_wp, 0.51_wp, 0.35_wp, & ! 11
478	0.32_wp, 0.40_wp, 0.24_wp, & ! 12
479	0.19_wp, 0.27_wp, 0.10_wp, & ! 13
480	0.77_wp, 0.65_wp, 0.90_wp, & ! 14
481	0.77_wp, 0.65_wp, 0.90_wp, & ! 15
482	0.82_wp, 0.70_wp, 0.95_wp, & ! 16
483	0.08_wp, 0.08_wp, 0.08_wp, & ! 17
484	0.17_wp, 0.17_wp, 0.17_wp, & ! 18
485	0.17_wp, 0.17_wp, 0.17_wp, & ! 19
486	0.30_wp, 0.30_wp, 0.30_wp, & ! 20
487	0.17_wp, 0.17_wp, 0.17_wp, & ! 21
488	0.17_wp, 0.17_wp, 0.17_wp, & ! 22
489	0.17_wp, 0.17_wp, 0.17_wp, & ! 23
490	0.17_wp, 0.17_wp, 0.17_wp, & ! 24
491	0.17_wp, 0.17_wp, 0.17_wp, & ! 25
492	0.17_wp, 0.17_wp, 0.17_wp, & ! 26
493	0.17_wp, 0.17_wp, 0.17_wp, & ! 27
494	0.17_wp, 0.17_wp, 0.17_wp, & ! 28
495	0.17_wp, 0.17_wp, 0.17_wp, & ! 29
496	0.17_wp, 0.17_wp, 0.17_wp, & ! 30
497	0.17_wp, 0.17_wp, 0.17_wp, & ! 31
498	0.17_wp, 0.17_wp, 0.17_wp, & ! 32
499	0.17_wp, 0.17_wp, 0.17_wp & ! 33
500	/), (/ 3, 33 /) )
501
502	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: &
503	rad_lw_cs_hr, & !< longwave clear sky radiation heating rate (K/s)
504	rad_lw_cs_hr_av, & !< average of rad_lw_cs_hr
505	rad_lw_hr, & !< longwave radiation heating rate (K/s)
506	rad_lw_hr_av, & !< average of rad_sw_hr
507	rad_lw_in, & !< incoming longwave radiation (W/m2)
508	rad_lw_in_av, & !< average of rad_lw_in
509	rad_lw_out, & !< outgoing longwave radiation (W/m2)
510	rad_lw_out_av, & !< average of rad_lw_out
511	rad_sw_cs_hr, & !< shortwave clear sky radiation heating rate (K/s)
512	rad_sw_cs_hr_av, & !< average of rad_sw_cs_hr
513	rad_sw_hr, & !< shortwave radiation heating rate (K/s)
514	rad_sw_hr_av, & !< average of rad_sw_hr
515	rad_sw_in, & !< incoming shortwave radiation (W/m2)
516	rad_sw_in_av, & !< average of rad_sw_in
517	rad_sw_out, & !< outgoing shortwave radiation (W/m2)
518	rad_sw_out_av !< average of rad_sw_out
519
520
521	!
522	!-- Variables and parameters used in RRTMG only
523	#if defined ( __rrtmg )
524	CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data)
525
526
527	!
528	!-- Flag parameters to be passed to RRTMG (should not be changed until ice phase in clouds is allowed)
529	INTEGER(iwp), PARAMETER :: rrtm_idrv = 1, & !< flag for longwave upward flux calculation option (0,1)
530	rrtm_inflglw = 2, & !< flag for lw cloud optical properties (0,1,2)
531	rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3)
532	rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications
533	rrtm_inflgsw = 2, & !< flag for sw cloud optical properties (0,1,2)
534	rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3)
535	rrtm_liqflgsw = 1 !< flag for sw liquid droplet specifications
536
537	!
538	!-- The following variables should be only changed with care, as this will
539	!-- require further setting of some variables, which is currently not
540	!-- implemented (aerosols, ice phase).
541	INTEGER(iwp) :: nzt_rad, & !< upper vertical limit for radiation calculations
542	rrtm_icld = 0, & !< cloud flag (0: clear sky column, 1: cloudy column)
543	rrtm_iaer = 0 !< aerosol option flag (0: no aerosol layers, for lw only: 6 (requires setting of rrtm_sw_ecaer), 10: one or more aerosol layers (not implemented)
544
545	INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling
546
547	LOGICAL :: snd_exists = .FALSE. !< flag parameter to check whether a user-defined input files exists
548	LOGICAL :: sw_exists = .FALSE. !< flag parameter to check whether that required rrtmg sw file exists
549	LOGICAL :: lw_exists = .FALSE. !< flag parameter to check whether that required rrtmg lw file exists
550
551
552	REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor
553
554	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd, & !< hypostatic pressure from sounding data (hPa)
555	rrtm_tsfc, & !< dummy array for storing surface temperature
556	t_snd !< actual temperature from sounding data (hPa)
557
558	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol)
559	rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol)
560	rrtm_cfc12vmr, & !< CFC12 volume mixing ratio (g/mol)
561	rrtm_cfc22vmr, & !< CFC22 volume mixing ratio (g/mol)
562	rrtm_ch4vmr, & !< CH4 volume mixing ratio
563	rrtm_cicewp, & !< in-cloud ice water path (g/m2)
564	rrtm_cldfr, & !< cloud fraction (0,1)
565	rrtm_cliqwp, & !< in-cloud liquid water path (g/m2)
566	rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol)
567	rrtm_emis, & !< surface emissivity (0-1)
568	rrtm_h2ovmr, & !< H2O volume mixing ratio
569	rrtm_n2ovmr, & !< N2O volume mixing ratio
570	rrtm_o2vmr, & !< O2 volume mixing ratio
571	rrtm_o3vmr, & !< O3 volume mixing ratio
572	rrtm_play, & !< pressure layers (hPa, zu-grid)
573	rrtm_plev, & !< pressure layers (hPa, zw-grid)
574	rrtm_reice, & !< cloud ice effective radius (microns)
575	rrtm_reliq, & !< cloud water drop effective radius (microns)
576	rrtm_tlay, & !< actual temperature (K, zu-grid)
577	rrtm_tlev, & !< actual temperature (K, zw-grid)
578	rrtm_lwdflx, & !< RRTM output of incoming longwave radiation flux (W/m2)
579	rrtm_lwdflxc, & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
580	rrtm_lwuflx, & !< RRTM output of outgoing longwave radiation flux (W/m2)
581	rrtm_lwuflxc, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
582	rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
583	rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
584	rrtm_lwhr, & !< RRTM output of longwave radiation heating rate (K/d)
585	rrtm_lwhrc, & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d)
586	rrtm_swdflx, & !< RRTM output of incoming shortwave radiation flux (W/m2)
587	rrtm_swdflxc, & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2)
588	rrtm_swuflx, & !< RRTM output of outgoing shortwave radiation flux (W/m2)
589	rrtm_swuflxc, & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2)
590	rrtm_swhr, & !< RRTM output of shortwave radiation heating rate (K/d)
591	rrtm_swhrc, & !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d)
592	rrtm_dirdflux, & !< RRTM output of incoming direct shortwave (W/m2)
593	rrtm_difdflux !< RRTM output of incoming diffuse shortwave (W/m2)
594
595	REAL(wp), DIMENSION(1) :: rrtm_aldif, & !< surface albedo for longwave diffuse radiation
596	rrtm_aldir, & !< surface albedo for longwave direct radiation
597	rrtm_asdif, & !< surface albedo for shortwave diffuse radiation
598	rrtm_asdir !< surface albedo for shortwave direct radiation
599
600	!
601	!-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters)
602	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rad_lw_cs_in, & !< incoming clear sky longwave radiation (W/m2) (not used)
603	rad_lw_cs_out, & !< outgoing clear sky longwave radiation (W/m2) (not used)
604	rad_sw_cs_in, & !< incoming clear sky shortwave radiation (W/m2) (not used)
605	rad_sw_cs_out, & !< outgoing clear sky shortwave radiation (W/m2) (not used)
606	rrtm_lw_tauaer, & !< lw aerosol optical depth
607	rrtm_lw_taucld, & !< lw in-cloud optical depth
608	rrtm_sw_taucld, & !< sw in-cloud optical depth
609	rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo
610	rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter
611	rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction
612	rrtm_sw_tauaer, & !< sw aerosol optical depth
613	rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo
614	rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter
615	rrtm_sw_ecaer !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only)
616
617	#endif
618	!
619	!-- Parameters of urban and land surface models
620	INTEGER(iwp) :: nz_urban !< number of layers of urban surface (will be calculated)
621	INTEGER(iwp) :: nz_plant !< number of layers of plant canopy (will be calculated)
622	INTEGER(iwp) :: nz_urban_b !< bottom layer of urban surface (will be calculated)
623	INTEGER(iwp) :: nz_urban_t !< top layer of urban surface (will be calculated)
624	INTEGER(iwp) :: nz_plant_t !< top layer of plant canopy (will be calculated)
625	!-- parameters of urban and land surface models
626	INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography
627	INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF
628	INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF
629	INTEGER(iwp), PARAMETER :: ndcsf = 1 !< number of dimensions of real values in CSF
630	INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF
631	INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array
632	INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf
633	INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf
634	INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf
635	INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf
636	INTEGER(iwp), PARAMETER :: im = 5 !< position of surface m-index in surfl and surf
637	INTEGER(iwp), PARAMETER :: nidx_surf = 5 !< number of indices in surfl and surf
638
639	INTEGER(iwp), PARAMETER :: nsurf_type = 10 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1
640
641	INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban upward surface (ground or roof)
642	INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging)
643	INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall
644	INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall
645	INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall
646	INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall
647
648	INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land upward surface (ground or roof)
649	INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall
650	INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall
651	INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall
652	INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall
653
654	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1/) !< surface normal direction x indices
655	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0/) !< surface normal direction y indices
656	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0/) !< surface normal direction z indices
657	REAL(wp), DIMENSION(0:nsurf_type) :: facearea !< area of single face in respective
658	!< direction (will be calc'd)
659
660
661	!-- indices and sizes of urban and land surface models
662	INTEGER(iwp) :: startland !< start index of block of land and roof surfaces
663	INTEGER(iwp) :: endland !< end index of block of land and roof surfaces
664	INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor
665	INTEGER(iwp) :: startwall !< start index of block of wall surfaces
666	INTEGER(iwp) :: endwall !< end index of block of wall surfaces
667	INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor
668
669	!-- indices needed for RTM netcdf output subroutines
670	INTEGER(iwp), PARAMETER :: nd = 5
671	CHARACTER(LEN=6), DIMENSION(0:nd-1), PARAMETER :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /)
672	INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_u = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /)
673	INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_l = (/ iup_l, isouth_l, inorth_l, iwest_l, ieast_l /)
674	INTEGER(iwp), DIMENSION(0:nd-1) :: dirstart
675	INTEGER(iwp), DIMENSION(0:nd-1) :: dirend
676
677	!-- indices and sizes of urban and land surface models
678	INTEGER(iwp), DIMENSION(:,:), POINTER :: surfl !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x, m]
679	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfl_linear !< dtto (linearly allocated array)
680	INTEGER(iwp), DIMENSION(:,:), POINTER :: surf !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x, m]
681	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surf_linear !< dtto (linearly allocated array)
682	INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor
683	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: nsurfs !< array of number of all surfaces in individual processors
684	INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs)
685	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfstart !< starts of blocks of surfaces for individual processors in array surf (indexed from 1)
686	!< respective block for particular processor is surfstart[iproc+1]+1 : surfstart[iproc+1]+nsurfs[iproc+1]
687
688	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
689	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy
690	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy
691	INTEGER(iwp) :: npcbl = 0 !< number of the plant canopy gridboxes in local processor
692	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i]
693	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box
694	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir !< array of absorbed direct sw radiation for local plant canopy box
695	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif !< array of absorbed diffusion sw radiation for local plant canopy box
696	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box
697
698	!-- configuration parameters (they can be setup in PALM config)
699	LOGICAL :: raytrace_mpi_rma = .TRUE. !< use MPI RMA to access LAD and gridsurf from remote processes during raytracing
700	LOGICAL :: rad_angular_discretization = .TRUE.!< whether to use fixed resolution discretization of view factors for
701	!< reflected radiation (as opposed to all mutually visible pairs)
702	LOGICAL :: plant_lw_interact = .TRUE. !< whether plant canopy interacts with LW radiation (in addition to SW)
703	INTEGER(iwp) :: mrt_nlevels = 0 !< number of vertical boxes above surface for which to calculate MRT
704	LOGICAL :: mrt_skip_roof = .TRUE. !< do not calculate MRT above roof surfaces
705	LOGICAL :: mrt_include_sw = .TRUE. !< should MRT calculation include SW radiation as well?
706	INTEGER(wp) :: mrt_geom = 1 !< method for MRT direction weights simulating a sphere or a human body
707	REAL(wp), DIMENSION(2) :: mrt_geom_params = (/ .12_wp, .88_wp /) !< parameters for the selected method
708	INTEGER(iwp) :: nrefsteps = 3 !< number of reflection steps to perform
709	REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha)
710	INTEGER(iwp), PARAMETER :: rad_version_len = 10 !< length of identification string of rad version
711	CHARACTER(rad_version_len), PARAMETER :: rad_version = 'RAD v. 3.0' !< identification of version of binary svf and restart files
712	INTEGER(iwp) :: raytrace_discrete_elevs = 40 !< number of discretization steps for elevation (nadir to zenith)
713	INTEGER(iwp) :: raytrace_discrete_azims = 80 !< number of discretization steps for azimuth (out of 360 degrees)
714	REAL(wp) :: max_raytracing_dist = -999.0_wp !< maximum distance for raytracing (in metres)
715	REAL(wp) :: min_irrf_value = 1e-6_wp !< minimum potential irradiance factor value for raytracing
716	REAL(wp), DIMENSION(1:30) :: svfnorm_report_thresh = 1e21_wp !< thresholds of SVF normalization values to report
717	INTEGER(iwp) :: svfnorm_report_num !< number of SVF normalization thresholds to report
718
719	!-- radiation related arrays to be used in radiation_interaction routine
720	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation
721	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation
722	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation
723
724	!-- parameters required for RRTMG lower boundary condition
725	REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond.
726	REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond.
727	REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond.
728
729	!-- type for calculation of svf
730	TYPE t_svf
731	INTEGER(iwp) :: isurflt !<
732	INTEGER(iwp) :: isurfs !<
733	REAL(wp) :: rsvf !<
734	REAL(wp) :: rtransp !<
735	END TYPE
736
737	!-- type for calculation of csf
738	TYPE t_csf
739	INTEGER(iwp) :: ip !<
740	INTEGER(iwp) :: itx !<
741	INTEGER(iwp) :: ity !<
742	INTEGER(iwp) :: itz !<
743	INTEGER(iwp) :: isurfs !< Idx of source face / -1 for sky
744	REAL(wp) :: rcvf !< Canopy view factor for faces /
745	!< canopy sink factor for sky (-1)
746	END TYPE
747
748	!-- arrays storing the values of USM
749	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of target and source surface for svf[isvf]
750	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local surfaces
751	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection
752	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection
753
754	REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvf !< array of sky view factor for each local surface
755	REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvft !< array of sky view factor including transparency for each local surface
756	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitrans !< dsidir[isvfl,i] = path transmittance of i-th
757	!< direction of direct solar irradiance per target surface
758	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitransc !< dtto per plant canopy box
759	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir !< dsidir[:,i] = unit vector of i-th
760	!< direction of direct solar irradiance
761	INTEGER(iwp) :: ndsidir !< number of apparent solar directions used
762	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: dsidir_rev !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present
763
764	INTEGER(iwp) :: nmrtbl !< No. of local grid boxes for which MRT is calculated
765	INTEGER(iwp) :: nmrtf !< number of MRT factors for local processor
766	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtbl !< coordinates of i-th local MRT box - surfl[:,i] = [z, y, x]
767	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtfsurf !< mrtfsurf[:,imrtf] = index of target MRT box and source surface for mrtf[imrtf]
768	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtf !< array of MRT factors for each local MRT box
769	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtft !< array of MRT factors including transparency for each local MRT box
770	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtsky !< array of sky view factor for each local MRT box
771	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtskyt !< array of sky view factor including transparency for each local MRT box
772	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: mrtdsit !< array of direct solar transparencies for each local MRT box
773	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw !< mean SW radiant flux for each MRT box
774	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw !< mean LW radiant flux for each MRT box
775	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt !< mean radiant temperature for each MRT box
776	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw_av !< time average mean SW radiant flux for each MRT box
777	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw_av !< time average mean LW radiant flux for each MRT box
778	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt_av !< time average mean radiant temperature for each MRT box
779
780	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections
781	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections
782	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface
783	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling to local surface
784	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling to local surface
785
786	!< Outward radiation is only valid for nonvirtual surfaces
787	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th reflection
788	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in i-th reflection
789	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th reflection
790	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in i-th reflection
791	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlg !< global array of incoming lw radiation from plant canopy
792	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
793	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
794	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfemitlwl !< array of emitted lw radiation for local surface used to calculate effective surface temperature for radiation model
795
796	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
797	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf]
798	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency)
799	REAL(wp), DIMENSION(:,:,:), POINTER :: sub_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate
800	#if defined( __parallel )
801	REAL(wp), DIMENSION(:), POINTER :: sub_lad_g !< sub_lad globalized (used to avoid MPI RMA calls in raytracing)
802	#endif
803	REAL(wp) :: prototype_lad !< prototype leaf area density for computing effective optical depth
804	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing
805	INTEGER(iwp) :: plantt_max
806
807	!-- arrays and variables for calculation of svf and csf
808	TYPE(t_svf), DIMENSION(:), POINTER :: asvf !< pointer to growing svc array
809	TYPE(t_csf), DIMENSION(:), POINTER :: acsf !< pointer to growing csf array
810	TYPE(t_svf), DIMENSION(:), POINTER :: amrtf !< pointer to growing mrtf array
811	TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array
812	TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array
813	TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: amrtf1, amrtf2 !< realizations of mftf array
814	INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor
815	INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor
816	INTEGER(iwp) :: nmrtfa !< dimmension of array allocated for storage of mrt
817	INTEGER(iwp) :: msvf, mcsf, mmrtf!< mod for swapping the growing array
818	INTEGER(iwp), PARAMETER :: gasize = 100000_iwp !< initial size of growing arrays
819	REAL(wp), PARAMETER :: grow_factor = 1.4_wp !< growth factor of growing arrays
820	INTEGER(iwp) :: nsvfl !< number of svf for local processor
821	INTEGER(iwp) :: ncsfl !< no. of csf in local processor
822	!< needed only during calc_svf but must be here because it is
823	!< shared between subroutines calc_svf and raytrace
824	INTEGER(iwp), DIMENSION(:,:,:,:), POINTER :: gridsurf !< reverse index of local surfl[d,k,j,i] (for case rad_angular_discretization)
825	INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< reverse index of local pcbl[k,j,i]
826	INTEGER(iwp), PARAMETER :: nsurf_type_u = 6 !< number of urban surf types (used in gridsurf)
827
828	!-- temporary arrays for calculation of csf in raytracing
829	INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain
830	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray
831	REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes
832	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored
833	#if defined( __parallel )
834	INTEGER(kind=MPI_ADDRESS_KIND), &
835	DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip
836	INTEGER(iwp) :: win_lad !< MPI RMA window for leaf area density
837	INTEGER(iwp) :: win_gridsurf !< MPI RMA window for reverse grid surface index
838	REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray
839	#endif
840	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: target_surfl
841	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: rt2_track
842	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rt2_track_lad
843	REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_track_dist
844	REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_dist
845
846	!-- arrays for time averages
847	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfradnet_av !< average of net radiation to local surface including radiation from reflections
848	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw_av !< average of sw radiation falling to local surface including radiation from reflections
849	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw_av !< average of lw radiation falling to local surface including radiation from reflections
850	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir_av !< average of direct sw radiation falling to local surface
851	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif_av !< average of diffuse sw radiation from sky and model boundary falling to local surface
852	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif_av !< average of diffuse lw radiation from sky and model boundary falling to local surface
853	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswref_av !< average of sw radiation falling to surface from reflections
854	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwref_av !< average of lw radiation falling to surface from reflections
855	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw_av !< average of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
856	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw_av !< average of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
857	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins_av !< average of array of residua of sw radiation absorbed in surface after last reflection
858	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl_av !< average of array of residua of lw radiation absorbed in surface after last reflection
859	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw_av !< Average of pcbinlw
860	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw_av !< Average of pcbinsw
861	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir_av !< Average of pcbinswdir
862	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif_av !< Average of pcbinswdif
863	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswref_av !< Average of pcbinswref
864
865
866	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
867	!-- Energy balance variables
868	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
869	!-- parameters of the land, roof and wall surfaces
870	REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf !< albedo of the surface
871	REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf !< emissivity of the wall surface
872	!
873	!-- External radiation. Depending on the given level of detail either a 1D or
874	!-- a 3D array will be allocated.
875	TYPE( real_1d_3d ) :: rad_lw_in_f !< external incoming longwave radiation, from observation or model
876	TYPE( real_1d_3d ) :: rad_sw_in_f !< external incoming shortwave radiation, from observation or model
877	TYPE( real_1d_3d ) :: rad_sw_in_dif_f !< external incoming shortwave radiation, diffuse part, from observation or model
878	TYPE( real_1d_3d ) :: time_rad_f !< time dimension for external radiation, from observation or model
879
880	INTERFACE radiation_check_data_output
881	MODULE PROCEDURE radiation_check_data_output
882	END INTERFACE radiation_check_data_output
883
884	INTERFACE radiation_check_data_output_ts
885	MODULE PROCEDURE radiation_check_data_output_ts
886	END INTERFACE radiation_check_data_output_ts
887
888	INTERFACE radiation_check_data_output_pr
889	MODULE PROCEDURE radiation_check_data_output_pr
890	END INTERFACE radiation_check_data_output_pr
891
892	INTERFACE radiation_check_parameters
893	MODULE PROCEDURE radiation_check_parameters
894	END INTERFACE radiation_check_parameters
895
896	INTERFACE radiation_clearsky
897	MODULE PROCEDURE radiation_clearsky
898	END INTERFACE radiation_clearsky
899
900	INTERFACE radiation_constant
901	MODULE PROCEDURE radiation_constant
902	END INTERFACE radiation_constant
903
904	INTERFACE radiation_control
905	MODULE PROCEDURE radiation_control
906	END INTERFACE radiation_control
907
908	INTERFACE radiation_3d_data_averaging
909	MODULE PROCEDURE radiation_3d_data_averaging
910	END INTERFACE radiation_3d_data_averaging
911
912	INTERFACE radiation_data_output_2d
913	MODULE PROCEDURE radiation_data_output_2d
914	END INTERFACE radiation_data_output_2d
915
916	INTERFACE radiation_data_output_3d
917	MODULE PROCEDURE radiation_data_output_3d
918	END INTERFACE radiation_data_output_3d
919
920	INTERFACE radiation_data_output_mask
921	MODULE PROCEDURE radiation_data_output_mask
922	END INTERFACE radiation_data_output_mask
923
924	INTERFACE radiation_define_netcdf_grid
925	MODULE PROCEDURE radiation_define_netcdf_grid
926	END INTERFACE radiation_define_netcdf_grid
927
928	INTERFACE radiation_header
929	MODULE PROCEDURE radiation_header
930	END INTERFACE radiation_header
931
932	INTERFACE radiation_init
933	MODULE PROCEDURE radiation_init
934	END INTERFACE radiation_init
935
936	INTERFACE radiation_parin
937	MODULE PROCEDURE radiation_parin
938	END INTERFACE radiation_parin
939
940	INTERFACE radiation_rrtmg
941	MODULE PROCEDURE radiation_rrtmg
942	END INTERFACE radiation_rrtmg
943
944	#if defined( __rrtmg )
945	INTERFACE radiation_tendency
946	MODULE PROCEDURE radiation_tendency
947	MODULE PROCEDURE radiation_tendency_ij
948	END INTERFACE radiation_tendency
949	#endif
950
951	INTERFACE radiation_rrd_local
952	MODULE PROCEDURE radiation_rrd_local
953	END INTERFACE radiation_rrd_local
954
955	INTERFACE radiation_wrd_local
956	MODULE PROCEDURE radiation_wrd_local
957	END INTERFACE radiation_wrd_local
958
959	INTERFACE radiation_interaction
960	MODULE PROCEDURE radiation_interaction
961	END INTERFACE radiation_interaction
962
963	INTERFACE radiation_interaction_init
964	MODULE PROCEDURE radiation_interaction_init
965	END INTERFACE radiation_interaction_init
966
967	INTERFACE radiation_presimulate_solar_pos
968	MODULE PROCEDURE radiation_presimulate_solar_pos
969	END INTERFACE radiation_presimulate_solar_pos
970
971	INTERFACE radiation_calc_svf
972	MODULE PROCEDURE radiation_calc_svf
973	END INTERFACE radiation_calc_svf
974
975	INTERFACE radiation_write_svf
976	MODULE PROCEDURE radiation_write_svf
977	END INTERFACE radiation_write_svf
978
979	INTERFACE radiation_read_svf
980	MODULE PROCEDURE radiation_read_svf
981	END INTERFACE radiation_read_svf
982
983
984	SAVE
985
986	PRIVATE
987
988	!
989	!-- Public functions / NEEDS SORTING
990	PUBLIC radiation_check_data_output, radiation_check_data_output_pr, &
991	radiation_check_data_output_ts, &
992	radiation_check_parameters, radiation_control, &
993	radiation_header, radiation_init, radiation_parin, &
994	radiation_3d_data_averaging, &
995	radiation_data_output_2d, radiation_data_output_3d, &
996	radiation_define_netcdf_grid, radiation_wrd_local, &
997	radiation_rrd_local, radiation_data_output_mask, &
998	radiation_calc_svf, radiation_write_svf, &
999	radiation_interaction, radiation_interaction_init, &
1000	radiation_read_svf, radiation_presimulate_solar_pos
1001
1002
1003	!
1004	!-- Public variables and constants / NEEDS SORTING
1005	PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,&
1006	emissivity, force_radiation_call, lat, lon, mrt_geom, &
1007	mrt_geom_params, &
1008	mrt_include_sw, mrt_nlevels, mrtbl, mrtinsw, mrtinlw, nmrtbl, &
1009	rad_net_av, radiation, radiation_scheme, rad_lw_in, &
1010	rad_lw_in_av, rad_lw_out, rad_lw_out_av, &
1011	rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in, &
1012	rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr, &
1013	rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, solar_constant, &
1014	skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,&
1015	cos_zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, &
1016	idir, jdir, kdir, id, iz, iy, ix, &
1017	iup_u, inorth_u, isouth_u, ieast_u, iwest_u, &
1018	iup_l, inorth_l, isouth_l, ieast_l, iwest_l, &
1019	nsurf_type, nz_urban_b, nz_urban_t, nz_urban, pch, nsurf, &
1020	idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, &
1021	radiation_interactions, startwall, startland, endland, endwall, &
1022	skyvf, skyvft, radiation_interactions_on, average_radiation, &
1023	rad_sw_in_diff, rad_sw_in_dir
1024
1025
1026	#if defined ( __rrtmg )
1027	PUBLIC radiation_tendency, rrtm_aldif, rrtm_aldir, rrtm_asdif, rrtm_asdir
1028	#endif
1029
1030	CONTAINS
1031
1032
1033	!------------------------------------------------------------------------------!
1034	! Description:
1035	! ------------
1036	!> This subroutine controls the calls of the radiation schemes
1037	!------------------------------------------------------------------------------!
1038	SUBROUTINE radiation_control
1039
1040
1041	IMPLICIT NONE
1042
1043
1044	IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'start' )
1045
1046
1047	SELECT CASE ( TRIM( radiation_scheme ) )
1048
1049	CASE ( 'constant' )
1050	CALL radiation_constant
1051
1052	CASE ( 'clear-sky' )
1053	CALL radiation_clearsky
1054
1055	CASE ( 'rrtmg' )
1056	CALL radiation_rrtmg
1057
1058	CASE ( 'external' )
1059	!
1060	!-- During spinup apply clear-sky model
1061	IF ( time_since_reference_point < 0.0_wp ) THEN
1062	CALL radiation_clearsky
1063	ELSE
1064	CALL radiation_external
1065	ENDIF
1066
1067	CASE DEFAULT
1068
1069	END SELECT
1070
1071	IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'end' )
1072
1073	END SUBROUTINE radiation_control
1074
1075	!------------------------------------------------------------------------------!
1076	! Description:
1077	! ------------
1078	!> Check data output for radiation model
1079	!------------------------------------------------------------------------------!
1080	SUBROUTINE radiation_check_data_output( variable, unit, i, ilen, k )
1081
1082
1083	USE control_parameters, &
1084	ONLY: data_output, message_string
1085
1086	IMPLICIT NONE
1087
1088	CHARACTER (LEN=*) :: unit !<
1089	CHARACTER (LEN=*) :: variable !<
1090
1091	INTEGER(iwp) :: i, k
1092	INTEGER(iwp) :: ilen
1093	CHARACTER(LEN=varnamelength) :: var !< TRIM(variable)
1094
1095	var = TRIM(variable)
1096
1097	IF ( len(var) < 3_iwp ) THEN
1098	unit = 'illegal'
1099	RETURN
1100	ENDIF
1101
1102	IF ( var(1:3) /= 'rad' .AND. var(1:3) /= 'rtm' ) THEN
1103	unit = 'illegal'
1104	RETURN
1105	ENDIF
1106
1107	!-- first process diractional variables
1108	IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. &
1109	var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. &
1110	var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. &
1111	var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. &
1112	var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. &
1113	var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' ) THEN
1114	IF ( .NOT. radiation ) THEN
1115	message_string = 'output of "' // TRIM( var ) // '" require'&
1116	// 's radiation = .TRUE.'
1117	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1118	ENDIF
1119	unit = 'W/m2'
1120	ELSE IF ( var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. &
1121	var(1:9) == 'rtm_skyvf' .OR. var(1:9) == 'rtm_skyvft' .OR. &
1122	var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' ) THEN
1123	IF ( .NOT. radiation ) THEN
1124	message_string = 'output of "' // TRIM( var ) // '" require'&
1125	// 's radiation = .TRUE.'
1126	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1127	ENDIF
1128	unit = '1'
1129	ELSE
1130	!-- non-directional variables
1131	SELECT CASE ( TRIM( var ) )
1132	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_lw_in', 'rad_lw_out', &
1133	'rad_sw_cs_hr', 'rad_sw_hr', 'rad_sw_in', 'rad_sw_out' )
1134	IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN
1135	message_string = '"output of "' // TRIM( var ) // '" requi' // &
1136	'res radiation = .TRUE. and ' // &
1137	'radiation_scheme = "rrtmg"'
1138	CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 )
1139	ENDIF
1140	unit = 'K/h'
1141
1142	CASE ( 'rad_net', 'rrtm_aldif', 'rrtm_aldir', 'rrtm_asdif', &
1143	'rrtm_asdir', 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', &
1144	'rad_sw_out*')
1145	IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN
1146	! Workaround for masked output (calls with i=ilen=k=0)
1147	unit = 'illegal'
1148	RETURN
1149	ENDIF
1150	IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN
1151	message_string = 'illegal value for data_output: "' // &
1152	TRIM( var ) // '" & only 2d-horizontal ' // &
1153	'cross sections are allowed for this value'
1154	CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 )
1155	ENDIF
1156	IF ( .NOT. radiation .OR. radiation_scheme /= "rrtmg" ) THEN
1157	IF ( TRIM( var ) == 'rrtm_aldif*' .OR. &
1158	TRIM( var ) == 'rrtm_aldir*' .OR. &
1159	TRIM( var ) == 'rrtm_asdif*' .OR. &
1160	TRIM( var ) == 'rrtm_asdir*' ) &
1161	THEN
1162	message_string = 'output of "' // TRIM( var ) // '" require'&
1163	// 's radiation = .TRUE. and radiation_sch'&
1164	// 'eme = "rrtmg"'
1165	CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 )
1166	ENDIF
1167	ENDIF
1168
1169	IF ( TRIM( var ) == 'rad_net*' ) unit = 'W/m2'
1170	IF ( TRIM( var ) == 'rad_lw_in*' ) unit = 'W/m2'
1171	IF ( TRIM( var ) == 'rad_lw_out*' ) unit = 'W/m2'
1172	IF ( TRIM( var ) == 'rad_sw_in*' ) unit = 'W/m2'
1173	IF ( TRIM( var ) == 'rad_sw_out*' ) unit = 'W/m2'
1174	IF ( TRIM( var ) == 'rad_sw_in' ) unit = 'W/m2'
1175	IF ( TRIM( var ) == 'rrtm_aldif*' ) unit = ''
1176	IF ( TRIM( var ) == 'rrtm_aldir*' ) unit = ''
1177	IF ( TRIM( var ) == 'rrtm_asdif*' ) unit = ''
1178	IF ( TRIM( var ) == 'rrtm_asdir*' ) unit = ''
1179
1180	CASE ( 'rtm_rad_pc_inlw', 'rtm_rad_pc_insw', 'rtm_rad_pc_inswdir', &
1181	'rtm_rad_pc_inswdif', 'rtm_rad_pc_inswref')
1182	IF ( .NOT. radiation ) THEN
1183	message_string = 'output of "' // TRIM( var ) // '" require'&
1184	// 's radiation = .TRUE.'
1185	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1186	ENDIF
1187	unit = 'W'
1188
1189	CASE ( 'rtm_mrt', 'rtm_mrt_sw', 'rtm_mrt_lw' )
1190	IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN
1191	! Workaround for masked output (calls with i=ilen=k=0)
1192	unit = 'illegal'
1193	RETURN
1194	ENDIF
1195
1196	IF ( .NOT. radiation ) THEN
1197	message_string = 'output of "' // TRIM( var ) // '" require'&
1198	// 's radiation = .TRUE.'
1199	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1200	ENDIF
1201	IF ( mrt_nlevels == 0 ) THEN
1202	message_string = 'output of "' // TRIM( var ) // '" require'&
1203	// 's mrt_nlevels > 0'
1204	CALL message( 'check_parameters', 'PA0510', 1, 2, 0, 6, 0 )
1205	ENDIF
1206	IF ( TRIM( var ) == 'rtm_mrt_sw' .AND. .NOT. mrt_include_sw ) THEN
1207	message_string = 'output of "' // TRIM( var ) // '" require'&
1208	// 's rtm_mrt_sw = .TRUE.'
1209	CALL message( 'check_parameters', 'PA0511', 1, 2, 0, 6, 0 )
1210	ENDIF
1211	IF ( TRIM( var ) == 'rtm_mrt' ) THEN
1212	unit = 'K'
1213	ELSE
1214	unit = 'W m-2'
1215	ENDIF
1216
1217	CASE DEFAULT
1218	unit = 'illegal'
1219
1220	END SELECT
1221	ENDIF
1222
1223	END SUBROUTINE radiation_check_data_output
1224
1225
1226	!------------------------------------------------------------------------------!
1227	! Description:
1228	! ------------
1229	!> Set module-specific timeseries units and labels
1230	!------------------------------------------------------------------------------!
1231	SUBROUTINE radiation_check_data_output_ts( dots_max, dots_num )
1232
1233
1234	INTEGER(iwp), INTENT(IN) :: dots_max
1235	INTEGER(iwp), INTENT(INOUT) :: dots_num
1236
1237	!
1238	!-- Next line is just to avoid compiler warning about unused variable.
1239	IF ( dots_max == 0 ) CONTINUE
1240
1241	!
1242	!-- Temporary solution to add LSM and radiation time series to the default
1243	!-- output
1244	IF ( land_surface .OR. radiation ) THEN
1245	IF ( TRIM( radiation_scheme ) == 'rrtmg' ) THEN
1246	dots_num = dots_num + 15
1247	ELSE
1248	dots_num = dots_num + 11
1249	ENDIF
1250	ENDIF
1251
1252
1253	END SUBROUTINE radiation_check_data_output_ts
1254
1255	!------------------------------------------------------------------------------!
1256	! Description:
1257	! ------------
1258	!> Check data output of profiles for radiation model
1259	!------------------------------------------------------------------------------!
1260	SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit, &
1261	dopr_unit )
1262
1263	USE arrays_3d, &
1264	ONLY: zu
1265
1266	USE control_parameters, &
1267	ONLY: data_output_pr, message_string
1268
1269	USE indices
1270
1271	USE profil_parameter
1272
1273	USE statistics
1274
1275	IMPLICIT NONE
1276
1277	CHARACTER (LEN=*) :: unit !<
1278	CHARACTER (LEN=*) :: variable !<
1279	CHARACTER (LEN=*) :: dopr_unit !< local value of dopr_unit
1280
1281	INTEGER(iwp) :: var_count !<
1282
1283	SELECT CASE ( TRIM( variable ) )
1284
1285	CASE ( 'rad_net' )
1286	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1287	THEN
1288	message_string = 'data_output_pr = ' // &
1289	TRIM( data_output_pr(var_count) ) // ' is' // &
1290	'not available for radiation = .FALSE. or ' //&
1291	'radiation_scheme = "constant"'
1292	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1293	ELSE
1294	dopr_index(var_count) = 99
1295	dopr_unit = 'W/m2'
1296	hom(:,2,99,:) = SPREAD( zw, 2, statistic_regions+1 )
1297	unit = dopr_unit
1298	ENDIF
1299
1300	CASE ( 'rad_lw_in' )
1301	IF ( ( .NOT. radiation) .OR. radiation_scheme == 'constant' ) &
1302	THEN
1303	message_string = 'data_output_pr = ' // &
1304	TRIM( data_output_pr(var_count) ) // ' is' // &
1305	'not available for radiation = .FALSE. or ' //&
1306	'radiation_scheme = "constant"'
1307	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1308	ELSE
1309	dopr_index(var_count) = 100
1310	dopr_unit = 'W/m2'
1311	hom(:,2,100,:) = SPREAD( zw, 2, statistic_regions+1 )
1312	unit = dopr_unit
1313	ENDIF
1314
1315	CASE ( 'rad_lw_out' )
1316	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1317	THEN
1318	message_string = 'data_output_pr = ' // &
1319	TRIM( data_output_pr(var_count) ) // ' is' // &
1320	'not available for radiation = .FALSE. or ' //&
1321	'radiation_scheme = "constant"'
1322	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1323	ELSE
1324	dopr_index(var_count) = 101
1325	dopr_unit = 'W/m2'
1326	hom(:,2,101,:) = SPREAD( zw, 2, statistic_regions+1 )
1327	unit = dopr_unit
1328	ENDIF
1329
1330	CASE ( 'rad_sw_in' )
1331	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1332	THEN
1333	message_string = 'data_output_pr = ' // &
1334	TRIM( data_output_pr(var_count) ) // ' is' // &
1335	'not available for radiation = .FALSE. or ' //&
1336	'radiation_scheme = "constant"'
1337	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1338	ELSE
1339	dopr_index(var_count) = 102
1340	dopr_unit = 'W/m2'
1341	hom(:,2,102,:) = SPREAD( zw, 2, statistic_regions+1 )
1342	unit = dopr_unit
1343	ENDIF
1344
1345	CASE ( 'rad_sw_out')
1346	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1347	THEN
1348	message_string = 'data_output_pr = ' // &
1349	TRIM( data_output_pr(var_count) ) // ' is' // &
1350	'not available for radiation = .FALSE. or ' //&
1351	'radiation_scheme = "constant"'
1352	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1353	ELSE
1354	dopr_index(var_count) = 103
1355	dopr_unit = 'W/m2'
1356	hom(:,2,103,:) = SPREAD( zw, 2, statistic_regions+1 )
1357	unit = dopr_unit
1358	ENDIF
1359
1360	CASE ( 'rad_lw_cs_hr' )
1361	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1362	THEN
1363	message_string = 'data_output_pr = ' // &
1364	TRIM( data_output_pr(var_count) ) // ' is' // &
1365	'not available for radiation = .FALSE. or ' //&
1366	'radiation_scheme /= "rrtmg"'
1367	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1368	ELSE
1369	dopr_index(var_count) = 104
1370	dopr_unit = 'K/h'
1371	hom(:,2,104,:) = SPREAD( zu, 2, statistic_regions+1 )
1372	unit = dopr_unit
1373	ENDIF
1374
1375	CASE ( 'rad_lw_hr' )
1376	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1377	THEN
1378	message_string = 'data_output_pr = ' // &
1379	TRIM( data_output_pr(var_count) ) // ' is' // &
1380	'not available for radiation = .FALSE. or ' //&
1381	'radiation_scheme /= "rrtmg"'
1382	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1383	ELSE
1384	dopr_index(var_count) = 105
1385	dopr_unit = 'K/h'
1386	hom(:,2,105,:) = SPREAD( zu, 2, statistic_regions+1 )
1387	unit = dopr_unit
1388	ENDIF
1389
1390	CASE ( 'rad_sw_cs_hr' )
1391	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1392	THEN
1393	message_string = 'data_output_pr = ' // &
1394	TRIM( data_output_pr(var_count) ) // ' is' // &
1395	'not available for radiation = .FALSE. or ' //&
1396	'radiation_scheme /= "rrtmg"'
1397	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1398	ELSE
1399	dopr_index(var_count) = 106
1400	dopr_unit = 'K/h'
1401	hom(:,2,106,:) = SPREAD( zu, 2, statistic_regions+1 )
1402	unit = dopr_unit
1403	ENDIF
1404
1405	CASE ( 'rad_sw_hr' )
1406	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1407	THEN
1408	message_string = 'data_output_pr = ' // &
1409	TRIM( data_output_pr(var_count) ) // ' is' // &
1410	'not available for radiation = .FALSE. or ' //&
1411	'radiation_scheme /= "rrtmg"'
1412	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1413	ELSE
1414	dopr_index(var_count) = 107
1415	dopr_unit = 'K/h'
1416	hom(:,2,107,:) = SPREAD( zu, 2, statistic_regions+1 )
1417	unit = dopr_unit
1418	ENDIF
1419
1420
1421	CASE DEFAULT
1422	unit = 'illegal'
1423
1424	END SELECT
1425
1426
1427	END SUBROUTINE radiation_check_data_output_pr
1428
1429
1430	!------------------------------------------------------------------------------!
1431	! Description:
1432	! ------------
1433	!> Check parameters routine for radiation model
1434	!------------------------------------------------------------------------------!
1435	SUBROUTINE radiation_check_parameters
1436
1437	USE control_parameters, &
1438	ONLY: land_surface, message_string, rotation_angle, urban_surface
1439
1440	USE netcdf_data_input_mod, &
1441	ONLY: input_pids_static
1442
1443	IMPLICIT NONE
1444
1445	!
1446	!-- In case no urban-surface or land-surface model is applied, usage of
1447	!-- a radiation model make no sense.
1448	IF ( .NOT. land_surface .AND. .NOT. urban_surface ) THEN
1449	message_string = 'Usage of radiation module is only allowed if ' // &
1450	'land-surface and/or urban-surface model is applied.'
1451	CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1452	ENDIF
1453
1454	IF ( radiation_scheme /= 'constant' .AND. &
1455	radiation_scheme /= 'clear-sky' .AND. &
1456	radiation_scheme /= 'rrtmg' .AND. &
1457	radiation_scheme /= 'external' ) THEN
1458	message_string = 'unknown radiation_scheme = '// &
1459	TRIM( radiation_scheme )
1460	CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 )
1461	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1462	#if ! defined ( __rrtmg )
1463	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1464	'compilation of PALM with pre-processor ' // &
1465	'directive -D__rrtmg'
1466	CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 )
1467	#endif
1468	#if defined ( __rrtmg ) && ! defined( __netcdf )
1469	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1470	'the use of NetCDF (preprocessor directive ' // &
1471	'-D__netcdf'
1472	CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 )
1473	#endif
1474
1475	ENDIF
1476	!
1477	!-- Checks performed only if data is given via namelist only.
1478	IF ( .NOT. input_pids_static ) THEN
1479	IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. &
1480	radiation_scheme == 'clear-sky') THEN
1481	message_string = 'radiation_scheme = "clear-sky" in combination'//&
1482	'with albedo_type = 0 requires setting of'// &
1483	'albedo /= 9999999.9'
1484	CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 )
1485	ENDIF
1486
1487	IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. &
1488	( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp&
1489	.OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp&
1490	) ) THEN
1491	message_string = 'radiation_scheme = "rrtmg" in combination' // &
1492	'with albedo_type = 0 requires setting of ' // &
1493	'albedo_lw_dif /= 9999999.9' // &
1494	'albedo_lw_dir /= 9999999.9' // &
1495	'albedo_sw_dif /= 9999999.9 and' // &
1496	'albedo_sw_dir /= 9999999.9'
1497	CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 )
1498	ENDIF
1499	ENDIF
1500	!
1501	!-- Parallel rad_angular_discretization without raytrace_mpi_rma is not implemented
1502	!-- Serial mode does not allow mpi_rma
1503	#if defined( __parallel )
1504	IF ( rad_angular_discretization .AND. .NOT. raytrace_mpi_rma ) THEN
1505	message_string = 'rad_angular_discretization can only be used ' // &
1506	'together with raytrace_mpi_rma or when ' // &
1507	'no parallelization is applied.'
1508	CALL message( 'readiation_check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1509	ENDIF
1510	#else
1511	IF ( raytrace_mpi_rma ) THEN
1512	message_string = 'raytrace_mpi_rma = .T. not allowed in serial mode'
1513	CALL message( 'readiation_check_parameters', 'PA0710', 1, 2, 0, 6, 0 )
1514	ENDIF
1515	#endif
1516
1517	IF ( cloud_droplets .AND. radiation_scheme == 'rrtmg' .AND. &
1518	average_radiation ) THEN
1519	message_string = 'average_radiation = .T. with radiation_scheme'// &
1520	'= "rrtmg" in combination cloud_droplets = .T.'// &
1521	'is not implementd'
1522	CALL message( 'check_parameters', 'PA0560', 1, 2, 0, 6, 0 )
1523	ENDIF
1524
1525	!
1526	!-- Incialize svf normalization reporting histogram
1527	svfnorm_report_num = 1
1528	DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1e20_wp &
1529	.AND. svfnorm_report_num <= 30 )
1530	svfnorm_report_num = svfnorm_report_num + 1
1531	ENDDO
1532	svfnorm_report_num = svfnorm_report_num - 1
1533	!
1534	!-- Check for dt_radiation
1535	IF ( dt_radiation <= 0.0 ) THEN
1536	message_string = 'dt_radiation must be > 0.0'
1537	CALL message( 'check_parameters', 'PA0591', 1, 2, 0, 6, 0 )
1538	ENDIF
1539	!
1540	!-- Check rotation angle
1541	!> @todo Remove this limitation
1542	IF ( rotation_angle /= 0.0 ) THEN
1543	message_string = 'rotation of the model domain is not considered in the radiation ' // &
1544	'model.&Using rotation_angle /= 0.0 is not allowed in combination ' // &
1545	'with the radiation model at the moment!'
1546	CALL message( 'check_parameters', 'PA0675', 1, 2, 0, 6, 0 )
1547	ENDIF
1548
1549	END SUBROUTINE radiation_check_parameters
1550
1551
1552	!------------------------------------------------------------------------------!
1553	! Description:
1554	! ------------
1555	!> Initialization of the radiation model and Radiative Transfer Model
1556	!------------------------------------------------------------------------------!
1557	SUBROUTINE radiation_init
1558
1559	IMPLICIT NONE
1560
1561	INTEGER(iwp) :: i !< running index x-direction
1562	INTEGER(iwp) :: is !< running index for input surface elements
1563	INTEGER(iwp) :: ioff !< offset in x between surface element reference grid point in atmosphere and actual surface
1564	INTEGER(iwp) :: j !< running index y-direction
1565	INTEGER(iwp) :: joff !< offset in y between surface element reference grid point in atmosphere and actual surface
1566	INTEGER(iwp) :: k !< running index z-direction
1567	INTEGER(iwp) :: l !< running index for orientation of vertical surfaces
1568	INTEGER(iwp) :: m !< running index for surface elements
1569	INTEGER(iwp) :: ntime = 0 !< number of available external radiation timesteps
1570	#if defined( __rrtmg )
1571	INTEGER(iwp) :: ind_type !< running index for subgrid-surface tiles
1572	#endif
1573	LOGICAL :: radiation_input_root_domain !< flag indicating the existence of a dynamic input file for the root domain
1574
1575
1576	IF ( debug_output ) CALL debug_message( 'radiation_init', 'start' )
1577	!
1578	!-- Activate radiation_interactions according to the existence of vertical surfaces and/or trees
1579	! or if biometeorology output is required for flat surfaces.
1580	!-- The namelist parameter radiation_interactions_on can override this behavior.
1581	!-- (This check cannot be performed in check_parameters, because vertical_surfaces_exist is first set in
1582	!-- init_surface_arrays.)
1583	IF ( radiation_interactions_on ) THEN
1584	IF ( vertical_surfaces_exist .OR. plant_canopy .OR. biometeorology ) THEN
1585	radiation_interactions = .TRUE.
1586	average_radiation = .TRUE.
1587	ELSE
1588	radiation_interactions_on = .FALSE. !< reset namelist parameter: no interactions
1589	!< calculations necessary in case of flat surface
1590	ENDIF
1591	ELSEIF ( vertical_surfaces_exist .OR. plant_canopy .OR. biometeorology ) THEN
1592	message_string = 'radiation_interactions_on is set to .FALSE. although ' // &
1593	'vertical surfaces and/or trees or biometeorology exist ' // &
1594	'is ON. The model will run without RTM (no shadows, no ' // &
1595	'radiation reflections)'
1596	CALL message( 'init_3d_model', 'PA0348', 0, 1, 0, 6, 0 )
1597	ENDIF
1598	!
1599	!-- Precalculate some time constants
1600	d_hours_day = 1.0_wp / REAL( hours_per_day, KIND = wp )
1601	d_seconds_hour = 1.0_wp / seconds_per_hour
1602
1603	!
1604	!-- If required, initialize radiation interactions between surfaces
1605	!-- via sky-view factors. This must be done before radiation is initialized.
1606	IF ( radiation_interactions ) CALL radiation_interaction_init
1607	!
1608	!-- Allocate array for storing the surface net radiation
1609	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. &
1610	surf_lsm_h%ns > 0 ) THEN
1611	ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) )
1612	surf_lsm_h%rad_net = 0.0_wp
1613	ENDIF
1614	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. &
1615	surf_usm_h%ns > 0 ) THEN
1616	ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) )
1617	surf_usm_h%rad_net = 0.0_wp
1618	ENDIF
1619	DO l = 0, 3
1620	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. &
1621	surf_lsm_v(l)%ns > 0 ) THEN
1622	ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) )
1623	surf_lsm_v(l)%rad_net = 0.0_wp
1624	ENDIF
1625	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. &
1626	surf_usm_v(l)%ns > 0 ) THEN
1627	ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) )
1628	surf_usm_v(l)%rad_net = 0.0_wp
1629	ENDIF
1630	ENDDO
1631
1632
1633	!
1634	!-- Allocate array for storing the surface longwave (out) radiation change
1635	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. &
1636	surf_lsm_h%ns > 0 ) THEN
1637	ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) )
1638	surf_lsm_h%rad_lw_out_change_0 = 0.0_wp
1639	ENDIF
1640	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. &
1641	surf_usm_h%ns > 0 ) THEN
1642	ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) )
1643	surf_usm_h%rad_lw_out_change_0 = 0.0_wp
1644	ENDIF
1645	DO l = 0, 3
1646	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. &
1647	surf_lsm_v(l)%ns > 0 ) THEN
1648	ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) )
1649	surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp
1650	ENDIF
1651	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. &
1652	surf_usm_v(l)%ns > 0 ) THEN
1653	ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) )
1654	surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp
1655	ENDIF
1656	ENDDO
1657
1658	!
1659	!-- Allocate surface arrays for incoming/outgoing short/longwave radiation
1660	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. &
1661	surf_lsm_h%ns > 0 ) THEN
1662	ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) )
1663	ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) )
1664	ALLOCATE( surf_lsm_h%rad_sw_dir(1:surf_lsm_h%ns) )
1665	ALLOCATE( surf_lsm_h%rad_sw_dif(1:surf_lsm_h%ns) )
1666	ALLOCATE( surf_lsm_h%rad_sw_ref(1:surf_lsm_h%ns) )
1667	ALLOCATE( surf_lsm_h%rad_sw_res(1:surf_lsm_h%ns) )
1668	ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) )
1669	ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) )
1670	ALLOCATE( surf_lsm_h%rad_lw_dif(1:surf_lsm_h%ns) )
1671	ALLOCATE( surf_lsm_h%rad_lw_ref(1:surf_lsm_h%ns) )
1672	ALLOCATE( surf_lsm_h%rad_lw_res(1:surf_lsm_h%ns) )
1673	surf_lsm_h%rad_sw_in = 0.0_wp
1674	surf_lsm_h%rad_sw_out = 0.0_wp
1675	surf_lsm_h%rad_sw_dir = 0.0_wp
1676	surf_lsm_h%rad_sw_dif = 0.0_wp
1677	surf_lsm_h%rad_sw_ref = 0.0_wp
1678	surf_lsm_h%rad_sw_res = 0.0_wp
1679	surf_lsm_h%rad_lw_in = 0.0_wp
1680	surf_lsm_h%rad_lw_out = 0.0_wp
1681	surf_lsm_h%rad_lw_dif = 0.0_wp
1682	surf_lsm_h%rad_lw_ref = 0.0_wp
1683	surf_lsm_h%rad_lw_res = 0.0_wp
1684	ENDIF
1685	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. &
1686	surf_usm_h%ns > 0 ) THEN
1687	ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) )
1688	ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) )
1689	ALLOCATE( surf_usm_h%rad_sw_dir(1:surf_usm_h%ns) )
1690	ALLOCATE( surf_usm_h%rad_sw_dif(1:surf_usm_h%ns) )
1691	ALLOCATE( surf_usm_h%rad_sw_ref(1:surf_usm_h%ns) )
1692	ALLOCATE( surf_usm_h%rad_sw_res(1:surf_usm_h%ns) )
1693	ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) )
1694	ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) )
1695	ALLOCATE( surf_usm_h%rad_lw_dif(1:surf_usm_h%ns) )
1696	ALLOCATE( surf_usm_h%rad_lw_ref(1:surf_usm_h%ns) )
1697	ALLOCATE( surf_usm_h%rad_lw_res(1:surf_usm_h%ns) )
1698	surf_usm_h%rad_sw_in = 0.0_wp
1699	surf_usm_h%rad_sw_out = 0.0_wp
1700	surf_usm_h%rad_sw_dir = 0.0_wp
1701	surf_usm_h%rad_sw_dif = 0.0_wp
1702	surf_usm_h%rad_sw_ref = 0.0_wp
1703	surf_usm_h%rad_sw_res = 0.0_wp
1704	surf_usm_h%rad_lw_in = 0.0_wp
1705	surf_usm_h%rad_lw_out = 0.0_wp
1706	surf_usm_h%rad_lw_dif = 0.0_wp
1707	surf_usm_h%rad_lw_ref = 0.0_wp
1708	surf_usm_h%rad_lw_res = 0.0_wp
1709	ENDIF
1710	DO l = 0, 3
1711	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. &
1712	surf_lsm_v(l)%ns > 0 ) THEN
1713	ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) )
1714	ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) )
1715	ALLOCATE( surf_lsm_v(l)%rad_sw_dir(1:surf_lsm_v(l)%ns) )
1716	ALLOCATE( surf_lsm_v(l)%rad_sw_dif(1:surf_lsm_v(l)%ns) )
1717	ALLOCATE( surf_lsm_v(l)%rad_sw_ref(1:surf_lsm_v(l)%ns) )
1718	ALLOCATE( surf_lsm_v(l)%rad_sw_res(1:surf_lsm_v(l)%ns) )
1719
1720	ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) )
1721	ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) )
1722	ALLOCATE( surf_lsm_v(l)%rad_lw_dif(1:surf_lsm_v(l)%ns) )
1723	ALLOCATE( surf_lsm_v(l)%rad_lw_ref(1:surf_lsm_v(l)%ns) )
1724	ALLOCATE( surf_lsm_v(l)%rad_lw_res(1:surf_lsm_v(l)%ns) )
1725
1726	surf_lsm_v(l)%rad_sw_in = 0.0_wp
1727	surf_lsm_v(l)%rad_sw_out = 0.0_wp
1728	surf_lsm_v(l)%rad_sw_dir = 0.0_wp
1729	surf_lsm_v(l)%rad_sw_dif = 0.0_wp
1730	surf_lsm_v(l)%rad_sw_ref = 0.0_wp
1731	surf_lsm_v(l)%rad_sw_res = 0.0_wp
1732
1733	surf_lsm_v(l)%rad_lw_in = 0.0_wp
1734	surf_lsm_v(l)%rad_lw_out = 0.0_wp
1735	surf_lsm_v(l)%rad_lw_dif = 0.0_wp
1736	surf_lsm_v(l)%rad_lw_ref = 0.0_wp
1737	surf_lsm_v(l)%rad_lw_res = 0.0_wp
1738	ENDIF
1739	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. &
1740	surf_usm_v(l)%ns > 0 ) THEN
1741	ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) )
1742	ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) )
1743	ALLOCATE( surf_usm_v(l)%rad_sw_dir(1:surf_usm_v(l)%ns) )
1744	ALLOCATE( surf_usm_v(l)%rad_sw_dif(1:surf_usm_v(l)%ns) )
1745	ALLOCATE( surf_usm_v(l)%rad_sw_ref(1:surf_usm_v(l)%ns) )
1746	ALLOCATE( surf_usm_v(l)%rad_sw_res(1:surf_usm_v(l)%ns) )
1747	ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) )
1748	ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) )
1749	ALLOCATE( surf_usm_v(l)%rad_lw_dif(1:surf_usm_v(l)%ns) )
1750	ALLOCATE( surf_usm_v(l)%rad_lw_ref(1:surf_usm_v(l)%ns) )
1751	ALLOCATE( surf_usm_v(l)%rad_lw_res(1:surf_usm_v(l)%ns) )
1752	surf_usm_v(l)%rad_sw_in = 0.0_wp
1753	surf_usm_v(l)%rad_sw_out = 0.0_wp
1754	surf_usm_v(l)%rad_sw_dir = 0.0_wp
1755	surf_usm_v(l)%rad_sw_dif = 0.0_wp
1756	surf_usm_v(l)%rad_sw_ref = 0.0_wp
1757	surf_usm_v(l)%rad_sw_res = 0.0_wp
1758	surf_usm_v(l)%rad_lw_in = 0.0_wp
1759	surf_usm_v(l)%rad_lw_out = 0.0_wp
1760	surf_usm_v(l)%rad_lw_dif = 0.0_wp
1761	surf_usm_v(l)%rad_lw_ref = 0.0_wp
1762	surf_usm_v(l)%rad_lw_res = 0.0_wp
1763	ENDIF
1764	ENDDO
1765	!
1766	!-- Fix net radiation in case of radiation_scheme = 'constant'
1767	IF ( radiation_scheme == 'constant' ) THEN
1768	IF ( ALLOCATED( surf_lsm_h%rad_net ) ) &
1769	surf_lsm_h%rad_net = net_radiation
1770	IF ( ALLOCATED( surf_usm_h%rad_net ) ) &
1771	surf_usm_h%rad_net = net_radiation
1772	!
1773	!-- Todo: weight with inclination angle
1774	DO l = 0, 3
1775	IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) &
1776	surf_lsm_v(l)%rad_net = net_radiation
1777	IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) &
1778	surf_usm_v(l)%rad_net = net_radiation
1779	ENDDO
1780	! radiation = .FALSE.
1781	!
1782	!-- Calculate orbital constants
1783	ELSE
1784	decl_1 = SIN(23.45_wp * pi / 180.0_wp)
1785	decl_2 = 2.0_wp * pi / 365.0_wp
1786	decl_3 = decl_2 * 81.0_wp
1787	lat = latitude * pi / 180.0_wp
1788	lon = longitude * pi / 180.0_wp
1789	ENDIF
1790
1791	IF ( radiation_scheme == 'clear-sky' .OR. &
1792	radiation_scheme == 'constant' .OR. &
1793	radiation_scheme == 'external' ) THEN
1794	!
1795	!-- Allocate arrays for incoming/outgoing short/longwave radiation
1796	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
1797	ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
1798	rad_sw_in = 0.0_wp
1799	ENDIF
1800	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
1801	ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
1802	rad_sw_out = 0.0_wp
1803	ENDIF
1804
1805	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
1806	ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
1807	rad_lw_in = 0.0_wp
1808	ENDIF
1809	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
1810	ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
1811	rad_lw_out = 0.0_wp
1812	ENDIF
1813
1814	!
1815	!-- Allocate average arrays for incoming/outgoing short/longwave radiation
1816	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
1817	ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1818	ENDIF
1819	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
1820	ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1821	ENDIF
1822
1823	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
1824	ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1825	ENDIF
1826	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
1827	ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1828	ENDIF
1829	!
1830	!-- Allocate arrays for broadband albedo, and level 1 initialization
1831	!-- via namelist paramter, unless not already allocated.
1832	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) THEN
1833	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
1834	surf_lsm_h%albedo = albedo
1835	ENDIF
1836	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) THEN
1837	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
1838	surf_usm_h%albedo = albedo
1839	ENDIF
1840
1841	DO l = 0, 3
1842	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) THEN
1843	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1844	surf_lsm_v(l)%albedo = albedo
1845	ENDIF
1846	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) THEN
1847	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1848	surf_usm_v(l)%albedo = albedo
1849	ENDIF
1850	ENDDO
1851	!
1852	!-- Level 2 initialization of broadband albedo via given albedo_type.
1853	!-- Only if albedo_type is non-zero. In case of urban surface and
1854	!-- input data is read from ASCII file, albedo_type will be zero, so that
1855	!-- albedo won't be overwritten.
1856	DO m = 1, surf_lsm_h%ns
1857	IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) /= 0 ) &
1858	surf_lsm_h%albedo(ind_veg_wall,m) = &
1859	albedo_pars(0,surf_lsm_h%albedo_type(ind_veg_wall,m))
1860	IF ( surf_lsm_h%albedo_type(ind_pav_green,m) /= 0 ) &
1861	surf_lsm_h%albedo(ind_pav_green,m) = &
1862	albedo_pars(0,surf_lsm_h%albedo_type(ind_pav_green,m))
1863	IF ( surf_lsm_h%albedo_type(ind_wat_win,m) /= 0 ) &
1864	surf_lsm_h%albedo(ind_wat_win,m) = &
1865	albedo_pars(0,surf_lsm_h%albedo_type(ind_wat_win,m))
1866	ENDDO
1867	DO m = 1, surf_usm_h%ns
1868	IF ( surf_usm_h%albedo_type(ind_veg_wall,m) /= 0 ) &
1869	surf_usm_h%albedo(ind_veg_wall,m) = &
1870	albedo_pars(0,surf_usm_h%albedo_type(ind_veg_wall,m))
1871	IF ( surf_usm_h%albedo_type(ind_pav_green,m) /= 0 ) &
1872	surf_usm_h%albedo(ind_pav_green,m) = &
1873	albedo_pars(0,surf_usm_h%albedo_type(ind_pav_green,m))
1874	IF ( surf_usm_h%albedo_type(ind_wat_win,m) /= 0 ) &
1875	surf_usm_h%albedo(ind_wat_win,m) = &
1876	albedo_pars(0,surf_usm_h%albedo_type(ind_wat_win,m))
1877	ENDDO
1878
1879	DO l = 0, 3
1880	DO m = 1, surf_lsm_v(l)%ns
1881	IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) &
1882	surf_lsm_v(l)%albedo(ind_veg_wall,m) = &
1883	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_veg_wall,m))
1884	IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) &
1885	surf_lsm_v(l)%albedo(ind_pav_green,m) = &
1886	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_pav_green,m))
1887	IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) &
1888	surf_lsm_v(l)%albedo(ind_wat_win,m) = &
1889	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_wat_win,m))
1890	ENDDO
1891	DO m = 1, surf_usm_v(l)%ns
1892	IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) &
1893	surf_usm_v(l)%albedo(ind_veg_wall,m) = &
1894	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_veg_wall,m))
1895	IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) &
1896	surf_usm_v(l)%albedo(ind_pav_green,m) = &
1897	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_pav_green,m))
1898	IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) &
1899	surf_usm_v(l)%albedo(ind_wat_win,m) = &
1900	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_wat_win,m))
1901	ENDDO
1902	ENDDO
1903
1904	!
1905	!-- Level 3 initialization at grid points where albedo type is zero.
1906	!-- This case, albedo is taken from file. In case of constant radiation
1907	!-- or clear sky, only broadband albedo is given.
1908	IF ( albedo_pars_f%from_file ) THEN
1909	!
1910	!-- Horizontal surfaces
1911	DO m = 1, surf_lsm_h%ns
1912	i = surf_lsm_h%i(m)
1913	j = surf_lsm_h%j(m)
1914	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1915	surf_lsm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1916	surf_lsm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1917	surf_lsm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1918	ENDIF
1919	ENDDO
1920	DO m = 1, surf_usm_h%ns
1921	i = surf_usm_h%i(m)
1922	j = surf_usm_h%j(m)
1923	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1924	surf_usm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1925	surf_usm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1926	surf_usm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1927	ENDIF
1928	ENDDO
1929	!
1930	!-- Vertical surfaces
1931	DO l = 0, 3
1932
1933	ioff = surf_lsm_v(l)%ioff
1934	joff = surf_lsm_v(l)%joff
1935	DO m = 1, surf_lsm_v(l)%ns
1936	i = surf_lsm_v(l)%i(m) + ioff
1937	j = surf_lsm_v(l)%j(m) + joff
1938	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1939	surf_lsm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1940	surf_lsm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1941	surf_lsm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1942	ENDIF
1943	ENDDO
1944
1945	ioff = surf_usm_v(l)%ioff
1946	joff = surf_usm_v(l)%joff
1947	DO m = 1, surf_usm_v(l)%ns
1948	i = surf_usm_v(l)%i(m) + ioff
1949	j = surf_usm_v(l)%j(m) + joff
1950	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1951	surf_usm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1952	surf_usm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1953	surf_usm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1954	ENDIF
1955	ENDDO
1956	ENDDO
1957
1958	ENDIF
1959	!
1960	!-- Read explicit albedo values from building surface pars. If present,
1961	!-- they override all less specific albedo values and force a albedo_type
1962	!-- to zero in order to take effect.
1963	IF ( building_surface_pars_f%from_file ) THEN
1964	DO m = 1, surf_usm_h%ns
1965	i = surf_usm_h%i(m)
1966	j = surf_usm_h%j(m)
1967	k = surf_usm_h%k(m)
1968	!
1969	!-- Iterate over surfaces in column, check height and orientation
1970	DO is = building_surface_pars_f%index_ji(1,j,i), &
1971	building_surface_pars_f%index_ji(2,j,i)
1972	IF ( building_surface_pars_f%coords(4,is) == -surf_usm_h%koff .AND. &
1973	building_surface_pars_f%coords(1,is) == k ) THEN
1974
1975	IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= &
1976	building_surface_pars_f%fill ) THEN
1977	surf_usm_h%albedo(ind_veg_wall,m) = &
1978	building_surface_pars_f%pars(ind_s_alb_b_wall,is)
1979	surf_usm_h%albedo_type(ind_veg_wall,m) = 0
1980	ENDIF
1981
1982	IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= &
1983	building_surface_pars_f%fill ) THEN
1984	surf_usm_h%albedo(ind_wat_win,m) = &
1985	building_surface_pars_f%pars(ind_s_alb_b_win,is)
1986	surf_usm_h%albedo_type(ind_wat_win,m) = 0
1987	ENDIF
1988
1989	IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= &
1990	building_surface_pars_f%fill ) THEN
1991	surf_usm_h%albedo(ind_pav_green,m) = &
1992	building_surface_pars_f%pars(ind_s_alb_b_green,is)
1993	surf_usm_h%albedo_type(ind_pav_green,m) = 0
1994	ENDIF
1995
1996	EXIT ! surface was found and processed
1997	ENDIF
1998	ENDDO
1999	ENDDO
2000
2001	DO l = 0, 3
2002	DO m = 1, surf_usm_v(l)%ns
2003	i = surf_usm_v(l)%i(m)
2004	j = surf_usm_v(l)%j(m)
2005	k = surf_usm_v(l)%k(m)
2006	!
2007	!-- Iterate over surfaces in column, check height and orientation
2008	DO is = building_surface_pars_f%index_ji(1,j,i), &
2009	building_surface_pars_f%index_ji(2,j,i)
2010	IF ( building_surface_pars_f%coords(5,is) == -surf_usm_v(l)%joff .AND. &
2011	building_surface_pars_f%coords(6,is) == -surf_usm_v(l)%ioff .AND. &
2012	building_surface_pars_f%coords(1,is) == k ) THEN
2013
2014	IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= &
2015	building_surface_pars_f%fill ) THEN
2016	surf_usm_v(l)%albedo(ind_veg_wall,m) = &
2017	building_surface_pars_f%pars(ind_s_alb_b_wall,is)
2018	surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
2019	ENDIF
2020
2021	IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= &
2022	building_surface_pars_f%fill ) THEN
2023	surf_usm_v(l)%albedo(ind_wat_win,m) = &
2024	building_surface_pars_f%pars(ind_s_alb_b_win,is)
2025	surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
2026	ENDIF
2027
2028	IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= &
2029	building_surface_pars_f%fill ) THEN
2030	surf_usm_v(l)%albedo(ind_pav_green,m) = &
2031	building_surface_pars_f%pars(ind_s_alb_b_green,is)
2032	surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
2033	ENDIF
2034
2035	EXIT ! surface was found and processed
2036	ENDIF
2037	ENDDO
2038	ENDDO
2039	ENDDO
2040	ENDIF
2041	!
2042	!-- Initialization actions for RRTMG
2043	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
2044	#if defined ( __rrtmg )
2045	!
2046	!-- Allocate albedos for short/longwave radiation, horizontal surfaces
2047	!-- for wall/green/window (USM) or vegetation/pavement/water surfaces
2048	!-- (LSM).
2049	ALLOCATE ( surf_lsm_h%aldif(0:2,1:surf_lsm_h%ns) )
2050	ALLOCATE ( surf_lsm_h%aldir(0:2,1:surf_lsm_h%ns) )
2051	ALLOCATE ( surf_lsm_h%asdif(0:2,1:surf_lsm_h%ns) )
2052	ALLOCATE ( surf_lsm_h%asdir(0:2,1:surf_lsm_h%ns) )
2053	ALLOCATE ( surf_lsm_h%rrtm_aldif(0:2,1:surf_lsm_h%ns) )
2054	ALLOCATE ( surf_lsm_h%rrtm_aldir(0:2,1:surf_lsm_h%ns) )
2055	ALLOCATE ( surf_lsm_h%rrtm_asdif(0:2,1:surf_lsm_h%ns) )
2056	ALLOCATE ( surf_lsm_h%rrtm_asdir(0:2,1:surf_lsm_h%ns) )
2057
2058	ALLOCATE ( surf_usm_h%aldif(0:2,1:surf_usm_h%ns) )
2059	ALLOCATE ( surf_usm_h%aldir(0:2,1:surf_usm_h%ns) )
2060	ALLOCATE ( surf_usm_h%asdif(0:2,1:surf_usm_h%ns) )
2061	ALLOCATE ( surf_usm_h%asdir(0:2,1:surf_usm_h%ns) )
2062	ALLOCATE ( surf_usm_h%rrtm_aldif(0:2,1:surf_usm_h%ns) )
2063	ALLOCATE ( surf_usm_h%rrtm_aldir(0:2,1:surf_usm_h%ns) )
2064	ALLOCATE ( surf_usm_h%rrtm_asdif(0:2,1:surf_usm_h%ns) )
2065	ALLOCATE ( surf_usm_h%rrtm_asdir(0:2,1:surf_usm_h%ns) )
2066
2067	!
2068	!-- Allocate broadband albedo (temporary for the current radiation
2069	!-- implementations)
2070	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) &
2071	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
2072	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) &
2073	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
2074
2075	!
2076	!-- Allocate albedos for short/longwave radiation, vertical surfaces
2077	DO l = 0, 3
2078
2079	ALLOCATE ( surf_lsm_v(l)%aldif(0:2,1:surf_lsm_v(l)%ns) )
2080	ALLOCATE ( surf_lsm_v(l)%aldir(0:2,1:surf_lsm_v(l)%ns) )
2081	ALLOCATE ( surf_lsm_v(l)%asdif(0:2,1:surf_lsm_v(l)%ns) )
2082	ALLOCATE ( surf_lsm_v(l)%asdir(0:2,1:surf_lsm_v(l)%ns) )
2083
2084	ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(0:2,1:surf_lsm_v(l)%ns) )
2085	ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(0:2,1:surf_lsm_v(l)%ns) )
2086	ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(0:2,1:surf_lsm_v(l)%ns) )
2087	ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(0:2,1:surf_lsm_v(l)%ns) )
2088
2089	ALLOCATE ( surf_usm_v(l)%aldif(0:2,1:surf_usm_v(l)%ns) )
2090	ALLOCATE ( surf_usm_v(l)%aldir(0:2,1:surf_usm_v(l)%ns) )
2091	ALLOCATE ( surf_usm_v(l)%asdif(0:2,1:surf_usm_v(l)%ns) )
2092	ALLOCATE ( surf_usm_v(l)%asdir(0:2,1:surf_usm_v(l)%ns) )
2093
2094	ALLOCATE ( surf_usm_v(l)%rrtm_aldif(0:2,1:surf_usm_v(l)%ns) )
2095	ALLOCATE ( surf_usm_v(l)%rrtm_aldir(0:2,1:surf_usm_v(l)%ns) )
2096	ALLOCATE ( surf_usm_v(l)%rrtm_asdif(0:2,1:surf_usm_v(l)%ns) )
2097	ALLOCATE ( surf_usm_v(l)%rrtm_asdir(0:2,1:surf_usm_v(l)%ns) )
2098	!
2099	!-- Allocate broadband albedo (temporary for the current radiation
2100	!-- implementations)
2101	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) &
2102	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
2103	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) &
2104	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
2105
2106	ENDDO
2107	!
2108	!-- Level 1 initialization of spectral albedos via namelist
2109	!-- paramters. Please note, this case all surface tiles are initialized
2110	!-- the same.
2111	IF ( surf_lsm_h%ns > 0 ) THEN
2112	surf_lsm_h%aldif = albedo_lw_dif
2113	surf_lsm_h%aldir = albedo_lw_dir
2114	surf_lsm_h%asdif = albedo_sw_dif
2115	surf_lsm_h%asdir = albedo_sw_dir
2116	surf_lsm_h%albedo = albedo_sw_dif
2117	ENDIF
2118	IF ( surf_usm_h%ns > 0 ) THEN
2119	IF ( surf_usm_h%albedo_from_ascii ) THEN
2120	surf_usm_h%aldif = surf_usm_h%albedo
2121	surf_usm_h%aldir = surf_usm_h%albedo
2122	surf_usm_h%asdif = surf_usm_h%albedo
2123	surf_usm_h%asdir = surf_usm_h%albedo
2124	ELSE
2125	surf_usm_h%aldif = albedo_lw_dif
2126	surf_usm_h%aldir = albedo_lw_dir
2127	surf_usm_h%asdif = albedo_sw_dif
2128	surf_usm_h%asdir = albedo_sw_dir
2129	surf_usm_h%albedo = albedo_sw_dif
2130	ENDIF
2131	ENDIF
2132
2133	DO l = 0, 3
2134
2135	IF ( surf_lsm_v(l)%ns > 0 ) THEN
2136	surf_lsm_v(l)%aldif = albedo_lw_dif
2137	surf_lsm_v(l)%aldir = albedo_lw_dir
2138	surf_lsm_v(l)%asdif = albedo_sw_dif
2139	surf_lsm_v(l)%asdir = albedo_sw_dir
2140	surf_lsm_v(l)%albedo = albedo_sw_dif
2141	ENDIF
2142
2143	IF ( surf_usm_v(l)%ns > 0 ) THEN
2144	IF ( surf_usm_v(l)%albedo_from_ascii ) THEN
2145	surf_usm_v(l)%aldif = surf_usm_v(l)%albedo
2146	surf_usm_v(l)%aldir = surf_usm_v(l)%albedo
2147	surf_usm_v(l)%asdif = surf_usm_v(l)%albedo
2148	surf_usm_v(l)%asdir = surf_usm_v(l)%albedo
2149	ELSE
2150	surf_usm_v(l)%aldif = albedo_lw_dif
2151	surf_usm_v(l)%aldir = albedo_lw_dir
2152	surf_usm_v(l)%asdif = albedo_sw_dif
2153	surf_usm_v(l)%asdir = albedo_sw_dir
2154	ENDIF
2155	ENDIF
2156	ENDDO
2157
2158	!
2159	!-- Level 2 initialization of spectral albedos via albedo_type.
2160	!-- Please note, for natural- and urban-type surfaces, a tile approach
2161	!-- is applied so that the resulting albedo is calculated via the weighted
2162	!-- average of respective surface fractions.
2163	DO m = 1, surf_lsm_h%ns
2164	!
2165	!-- Spectral albedos for vegetation/pavement/water surfaces
2166	DO ind_type = 0, 2
2167	IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 ) THEN
2168	surf_lsm_h%aldif(ind_type,m) = &
2169	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
2170	surf_lsm_h%asdif(ind_type,m) = &
2171	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
2172	surf_lsm_h%aldir(ind_type,m) = &
2173	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
2174	surf_lsm_h%asdir(ind_type,m) = &
2175	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
2176	surf_lsm_h%albedo(ind_type,m) = &
2177	albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m))
2178	ENDIF
2179	ENDDO
2180
2181	ENDDO
2182	!
2183	!-- For urban surface only if albedo has not been already initialized
2184	!-- in the urban-surface model via the ASCII file.
2185	IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN
2186	DO m = 1, surf_usm_h%ns
2187	!
2188	!-- Spectral albedos for wall/green/window surfaces
2189	DO ind_type = 0, 2
2190	IF ( surf_usm_h%albedo_type(ind_type,m) /= 0 ) THEN
2191	surf_usm_h%aldif(ind_type,m) = &
2192	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2193	surf_usm_h%asdif(ind_type,m) = &
2194	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2195	surf_usm_h%aldir(ind_type,m) = &
2196	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2197	surf_usm_h%asdir(ind_type,m) = &
2198	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2199	surf_usm_h%albedo(ind_type,m) = &
2200	albedo_pars(0,surf_usm_h%albedo_type(ind_type,m))
2201	ENDIF
2202	ENDDO
2203
2204	ENDDO
2205	ENDIF
2206
2207	DO l = 0, 3
2208
2209	DO m = 1, surf_lsm_v(l)%ns
2210	!
2211	!-- Spectral albedos for vegetation/pavement/water surfaces
2212	DO ind_type = 0, 2
2213	IF ( surf_lsm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
2214	surf_lsm_v(l)%aldif(ind_type,m) = &
2215	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2216	surf_lsm_v(l)%asdif(ind_type,m) = &
2217	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2218	surf_lsm_v(l)%aldir(ind_type,m) = &
2219	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2220	surf_lsm_v(l)%asdir(ind_type,m) = &
2221	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2222	surf_lsm_v(l)%albedo(ind_type,m) = &
2223	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m))
2224	ENDIF
2225	ENDDO
2226	ENDDO
2227	!
2228	!-- For urban surface only if albedo has not been already initialized
2229	!-- in the urban-surface model via the ASCII file.
2230	IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN
2231	DO m = 1, surf_usm_v(l)%ns
2232	!
2233	!-- Spectral albedos for wall/green/window surfaces
2234	DO ind_type = 0, 2
2235	IF ( surf_usm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
2236	surf_usm_v(l)%aldif(ind_type,m) = &
2237	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2238	surf_usm_v(l)%asdif(ind_type,m) = &
2239	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2240	surf_usm_v(l)%aldir(ind_type,m) = &
2241	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2242	surf_usm_v(l)%asdir(ind_type,m) = &
2243	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2244	surf_usm_v(l)%albedo(ind_type,m) = &
2245	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m))
2246	ENDIF
2247	ENDDO
2248
2249	ENDDO
2250	ENDIF
2251	ENDDO
2252	!
2253	!-- Level 3 initialization at grid points where albedo type is zero.
2254	!-- This case, spectral albedos are taken from file if available
2255	IF ( albedo_pars_f%from_file ) THEN
2256	!
2257	!-- Horizontal
2258	DO m = 1, surf_lsm_h%ns
2259	i = surf_lsm_h%i(m)
2260	j = surf_lsm_h%j(m)
2261	!
2262	!-- Spectral albedos for vegetation/pavement/water surfaces
2263	DO ind_type = 0, 2
2264	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) &
2265	surf_lsm_h%albedo(ind_type,m) = &
2266	albedo_pars_f%pars_xy(0,j,i)
2267	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) &
2268	surf_lsm_h%aldir(ind_type,m) = &
2269	albedo_pars_f%pars_xy(1,j,i)
2270	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) &
2271	surf_lsm_h%aldif(ind_type,m) = &
2272	albedo_pars_f%pars_xy(1,j,i)
2273	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) &
2274	surf_lsm_h%asdir(ind_type,m) = &
2275	albedo_pars_f%pars_xy(2,j,i)
2276	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) &
2277	surf_lsm_h%asdif(ind_type,m) = &
2278	albedo_pars_f%pars_xy(2,j,i)
2279	ENDDO
2280	ENDDO
2281	!
2282	!-- For urban surface only if albedo has not been already initialized
2283	!-- in the urban-surface model via the ASCII file.
2284	IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN
2285	DO m = 1, surf_usm_h%ns
2286	i = surf_usm_h%i(m)
2287	j = surf_usm_h%j(m)
2288	!
2289	!-- Broadband albedos for wall/green/window surfaces
2290	DO ind_type = 0, 2
2291	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )&
2292	surf_usm_h%albedo(ind_type,m) = &
2293	albedo_pars_f%pars_xy(0,j,i)
2294	ENDDO
2295	!
2296	!-- Spectral albedos especially for building wall surfaces
2297	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) THEN
2298	surf_usm_h%aldir(ind_veg_wall,m) = &
2299	albedo_pars_f%pars_xy(1,j,i)
2300	surf_usm_h%aldif(ind_veg_wall,m) = &
2301	albedo_pars_f%pars_xy(1,j,i)
2302	ENDIF
2303	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) THEN
2304	surf_usm_h%asdir(ind_veg_wall,m) = &
2305	albedo_pars_f%pars_xy(2,j,i)
2306	surf_usm_h%asdif(ind_veg_wall,m) = &
2307	albedo_pars_f%pars_xy(2,j,i)
2308	ENDIF
2309	!
2310	!-- Spectral albedos especially for building green surfaces
2311	IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) THEN
2312	surf_usm_h%aldir(ind_pav_green,m) = &
2313	albedo_pars_f%pars_xy(3,j,i)
2314	surf_usm_h%aldif(ind_pav_green,m) = &
2315	albedo_pars_f%pars_xy(3,j,i)
2316	ENDIF
2317	IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) THEN
2318	surf_usm_h%asdir(ind_pav_green,m) = &
2319	albedo_pars_f%pars_xy(4,j,i)
2320	surf_usm_h%asdif(ind_pav_green,m) = &
2321	albedo_pars_f%pars_xy(4,j,i)
2322	ENDIF
2323	!
2324	!-- Spectral albedos especially for building window surfaces
2325	IF ( albedo_pars_f%pars_xy(5,j,i) /= albedo_pars_f%fill ) THEN
2326	surf_usm_h%aldir(ind_wat_win,m) = &
2327	albedo_pars_f%pars_xy(5,j,i)
2328	surf_usm_h%aldif(ind_wat_win,m) = &
2329	albedo_pars_f%pars_xy(5,j,i)
2330	ENDIF
2331	IF ( albedo_pars_f%pars_xy(6,j,i) /= albedo_pars_f%fill ) THEN
2332	surf_usm_h%asdir(ind_wat_win,m) = &
2333	albedo_pars_f%pars_xy(6,j,i)
2334	surf_usm_h%asdif(ind_wat_win,m) = &
2335	albedo_pars_f%pars_xy(6,j,i)
2336	ENDIF
2337
2338	ENDDO
2339	ENDIF
2340	!
2341	!-- Vertical
2342	DO l = 0, 3
2343	ioff = surf_lsm_v(l)%ioff
2344	joff = surf_lsm_v(l)%joff
2345
2346	DO m = 1, surf_lsm_v(l)%ns
2347	i = surf_lsm_v(l)%i(m)
2348	j = surf_lsm_v(l)%j(m)
2349	!
2350	!-- Spectral albedos for vegetation/pavement/water surfaces
2351	DO ind_type = 0, 2
2352	IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= &
2353	albedo_pars_f%fill ) &
2354	surf_lsm_v(l)%albedo(ind_type,m) = &
2355	albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2356	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2357	albedo_pars_f%fill ) &
2358	surf_lsm_v(l)%aldir(ind_type,m) = &
2359	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2360	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2361	albedo_pars_f%fill ) &
2362	surf_lsm_v(l)%aldif(ind_type,m) = &
2363	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2364	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2365	albedo_pars_f%fill ) &
2366	surf_lsm_v(l)%asdir(ind_type,m) = &
2367	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2368	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2369	albedo_pars_f%fill ) &
2370	surf_lsm_v(l)%asdif(ind_type,m) = &
2371	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2372	ENDDO
2373	ENDDO
2374	!
2375	!-- For urban surface only if albedo has not been already initialized
2376	!-- in the urban-surface model via the ASCII file.
2377	IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN
2378	ioff = surf_usm_v(l)%ioff
2379	joff = surf_usm_v(l)%joff
2380
2381	DO m = 1, surf_usm_v(l)%ns
2382	i = surf_usm_v(l)%i(m)
2383	j = surf_usm_v(l)%j(m)
2384	!
2385	!-- Broadband albedos for wall/green/window surfaces
2386	DO ind_type = 0, 2
2387	IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= &
2388	albedo_pars_f%fill ) &
2389	surf_usm_v(l)%albedo(ind_type,m) = &
2390	albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2391	ENDDO
2392	!
2393	!-- Spectral albedos especially for building wall surfaces
2394	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2395	albedo_pars_f%fill ) THEN
2396	surf_usm_v(l)%aldir(ind_veg_wall,m) = &
2397	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2398	surf_usm_v(l)%aldif(ind_veg_wall,m) = &
2399	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2400	ENDIF
2401	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2402	albedo_pars_f%fill ) THEN
2403	surf_usm_v(l)%asdir(ind_veg_wall,m) = &
2404	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2405	surf_usm_v(l)%asdif(ind_veg_wall,m) = &
2406	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2407	ENDIF
2408	!
2409	!-- Spectral albedos especially for building green surfaces
2410	IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= &
2411	albedo_pars_f%fill ) THEN
2412	surf_usm_v(l)%aldir(ind_pav_green,m) = &
2413	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2414	surf_usm_v(l)%aldif(ind_pav_green,m) = &
2415	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2416	ENDIF
2417	IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= &
2418	albedo_pars_f%fill ) THEN
2419	surf_usm_v(l)%asdir(ind_pav_green,m) = &
2420	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2421	surf_usm_v(l)%asdif(ind_pav_green,m) = &
2422	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2423	ENDIF
2424	!
2425	!-- Spectral albedos especially for building window surfaces
2426	IF ( albedo_pars_f%pars_xy(5,j+joff,i+ioff) /= &
2427	albedo_pars_f%fill ) THEN
2428	surf_usm_v(l)%aldir(ind_wat_win,m) = &
2429	albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2430	surf_usm_v(l)%aldif(ind_wat_win,m) = &
2431	albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2432	ENDIF
2433	IF ( albedo_pars_f%pars_xy(6,j+joff,i+ioff) /= &
2434	albedo_pars_f%fill ) THEN
2435	surf_usm_v(l)%asdir(ind_wat_win,m) = &
2436	albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2437	surf_usm_v(l)%asdif(ind_wat_win,m) = &
2438	albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2439	ENDIF
2440	ENDDO
2441	ENDIF
2442	ENDDO
2443
2444	ENDIF
2445	!
2446	!-- Read explicit albedo values from building surface pars. If present,
2447	!-- they override all less specific albedo values and force a albedo_type
2448	!-- to zero in order to take effect.
2449	IF ( building_surface_pars_f%from_file ) THEN
2450	DO m = 1, surf_usm_h%ns
2451	i = surf_usm_h%i(m)
2452	j = surf_usm_h%j(m)
2453	k = surf_usm_h%k(m)
2454	!
2455	!-- Iterate over surfaces in column, check height and orientation
2456	DO is = building_surface_pars_f%index_ji(1,j,i), &
2457	building_surface_pars_f%index_ji(2,j,i)
2458	IF ( building_surface_pars_f%coords(4,is) == -surf_usm_h%koff .AND. &
2459	building_surface_pars_f%coords(1,is) == k ) THEN
2460
2461	IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= &
2462	building_surface_pars_f%fill ) THEN
2463	surf_usm_h%albedo(ind_veg_wall,m) = &
2464	building_surface_pars_f%pars(ind_s_alb_b_wall,is)
2465	surf_usm_h%albedo_type(ind_veg_wall,m) = 0
2466	ENDIF
2467
2468	IF ( building_surface_pars_f%pars(ind_s_alb_l_wall,is) /= &
2469	building_surface_pars_f%fill ) THEN
2470	surf_usm_h%aldir(ind_veg_wall,m) = &
2471	building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2472	surf_usm_h%aldif(ind_veg_wall,m) = &
2473	building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2474	surf_usm_h%albedo_type(ind_veg_wall,m) = 0
2475	ENDIF
2476
2477	IF ( building_surface_pars_f%pars(ind_s_alb_s_wall,is) /= &
2478	building_surface_pars_f%fill ) THEN
2479	surf_usm_h%asdir(ind_veg_wall,m) = &
2480	building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2481	surf_usm_h%asdif(ind_veg_wall,m) = &
2482	building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2483	surf_usm_h%albedo_type(ind_veg_wall,m) = 0
2484	ENDIF
2485
2486	IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= &
2487	building_surface_pars_f%fill ) THEN
2488	surf_usm_h%albedo(ind_wat_win,m) = &
2489	building_surface_pars_f%pars(ind_s_alb_b_win,is)
2490	surf_usm_h%albedo_type(ind_wat_win,m) = 0
2491	ENDIF
2492
2493	IF ( building_surface_pars_f%pars(ind_s_alb_l_win,is) /= &
2494	building_surface_pars_f%fill ) THEN
2495	surf_usm_h%aldir(ind_wat_win,m) = &
2496	building_surface_pars_f%pars(ind_s_alb_l_win,is)
2497	surf_usm_h%aldif(ind_wat_win,m) = &
2498	building_surface_pars_f%pars(ind_s_alb_l_win,is)
2499	surf_usm_h%albedo_type(ind_wat_win,m) = 0
2500	ENDIF
2501
2502	IF ( building_surface_pars_f%pars(ind_s_alb_s_win,is) /= &
2503	building_surface_pars_f%fill ) THEN
2504	surf_usm_h%asdir(ind_wat_win,m) = &
2505	building_surface_pars_f%pars(ind_s_alb_s_win,is)
2506	surf_usm_h%asdif(ind_wat_win,m) = &
2507	building_surface_pars_f%pars(ind_s_alb_s_win,is)
2508	surf_usm_h%albedo_type(ind_wat_win,m) = 0
2509	ENDIF
2510
2511	IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= &
2512	building_surface_pars_f%fill ) THEN
2513	surf_usm_h%albedo(ind_pav_green,m) = &
2514	building_surface_pars_f%pars(ind_s_alb_b_green,is)
2515	surf_usm_h%albedo_type(ind_pav_green,m) = 0
2516	ENDIF
2517
2518	IF ( building_surface_pars_f%pars(ind_s_alb_l_green,is) /= &
2519	building_surface_pars_f%fill ) THEN
2520	surf_usm_h%aldir(ind_pav_green,m) = &
2521	building_surface_pars_f%pars(ind_s_alb_l_green,is)
2522	surf_usm_h%aldif(ind_pav_green,m) = &
2523	building_surface_pars_f%pars(ind_s_alb_l_green,is)
2524	surf_usm_h%albedo_type(ind_pav_green,m) = 0
2525	ENDIF
2526
2527	IF ( building_surface_pars_f%pars(ind_s_alb_s_green,is) /= &
2528	building_surface_pars_f%fill ) THEN
2529	surf_usm_h%asdir(ind_pav_green,m) = &
2530	building_surface_pars_f%pars(ind_s_alb_s_green,is)
2531	surf_usm_h%asdif(ind_pav_green,m) = &
2532	building_surface_pars_f%pars(ind_s_alb_s_green,is)
2533	surf_usm_h%albedo_type(ind_pav_green,m) = 0
2534	ENDIF
2535
2536	EXIT ! surface was found and processed
2537	ENDIF
2538	ENDDO
2539	ENDDO
2540
2541	DO l = 0, 3
2542	DO m = 1, surf_usm_v(l)%ns
2543	i = surf_usm_v(l)%i(m)
2544	j = surf_usm_v(l)%j(m)
2545	k = surf_usm_v(l)%k(m)
2546	!
2547	!-- Iterate over surfaces in column, check height and orientation
2548	DO is = building_surface_pars_f%index_ji(1,j,i), &
2549	building_surface_pars_f%index_ji(2,j,i)
2550	IF ( building_surface_pars_f%coords(5,is) == -surf_usm_v(l)%joff .AND. &
2551	building_surface_pars_f%coords(6,is) == -surf_usm_v(l)%ioff .AND. &
2552	building_surface_pars_f%coords(1,is) == k ) THEN
2553
2554	IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= &
2555	building_surface_pars_f%fill ) THEN
2556	surf_usm_v(l)%albedo(ind_veg_wall,m) = &
2557	building_surface_pars_f%pars(ind_s_alb_b_wall,is)
2558	surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
2559	ENDIF
2560
2561	IF ( building_surface_pars_f%pars(ind_s_alb_l_wall,is) /= &
2562	building_surface_pars_f%fill ) THEN
2563	surf_usm_v(l)%aldir(ind_veg_wall,m) = &
2564	building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2565	surf_usm_v(l)%aldif(ind_veg_wall,m) = &
2566	building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2567	surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
2568	ENDIF
2569
2570	IF ( building_surface_pars_f%pars(ind_s_alb_s_wall,is) /= &
2571	building_surface_pars_f%fill ) THEN
2572	surf_usm_v(l)%asdir(ind_veg_wall,m) = &
2573	building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2574	surf_usm_v(l)%asdif(ind_veg_wall,m) = &
2575	building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2576	surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
2577	ENDIF
2578
2579	IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= &
2580	building_surface_pars_f%fill ) THEN
2581	surf_usm_v(l)%albedo(ind_wat_win,m) = &
2582	building_surface_pars_f%pars(ind_s_alb_b_win,is)
2583	surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
2584	ENDIF
2585
2586	IF ( building_surface_pars_f%pars(ind_s_alb_l_win,is) /= &
2587	building_surface_pars_f%fill ) THEN
2588	surf_usm_v(l)%aldir(ind_wat_win,m) = &
2589	building_surface_pars_f%pars(ind_s_alb_l_win,is)
2590	surf_usm_v(l)%aldif(ind_wat_win,m) = &
2591	building_surface_pars_f%pars(ind_s_alb_l_win,is)
2592	surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
2593	ENDIF
2594
2595	IF ( building_surface_pars_f%pars(ind_s_alb_s_win,is) /= &
2596	building_surface_pars_f%fill ) THEN
2597	surf_usm_v(l)%asdir(ind_wat_win,m) = &
2598	building_surface_pars_f%pars(ind_s_alb_s_win,is)
2599	surf_usm_v(l)%asdif(ind_wat_win,m) = &
2600	building_surface_pars_f%pars(ind_s_alb_s_win,is)
2601	surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
2602	ENDIF
2603
2604	IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= &
2605	building_surface_pars_f%fill ) THEN
2606	surf_usm_v(l)%albedo(ind_pav_green,m) = &
2607	building_surface_pars_f%pars(ind_s_alb_b_green,is)
2608	surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
2609	ENDIF
2610
2611	IF ( building_surface_pars_f%pars(ind_s_alb_l_green,is) /= &
2612	building_surface_pars_f%fill ) THEN
2613	surf_usm_v(l)%aldir(ind_pav_green,m) = &
2614	building_surface_pars_f%pars(ind_s_alb_l_green,is)
2615	surf_usm_v(l)%aldif(ind_pav_green,m) = &
2616	building_surface_pars_f%pars(ind_s_alb_l_green,is)
2617	surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
2618	ENDIF
2619
2620	IF ( building_surface_pars_f%pars(ind_s_alb_s_green,is) /= &
2621	building_surface_pars_f%fill ) THEN
2622	surf_usm_v(l)%asdir(ind_pav_green,m) = &
2623	building_surface_pars_f%pars(ind_s_alb_s_green,is)
2624	surf_usm_v(l)%asdif(ind_pav_green,m) = &
2625	building_surface_pars_f%pars(ind_s_alb_s_green,is)
2626	surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
2627	ENDIF
2628
2629	EXIT ! surface was found and processed
2630	ENDIF
2631	ENDDO
2632	ENDDO
2633	ENDDO
2634	ENDIF
2635
2636	!
2637	!-- Calculate initial values of current (cosine of) the zenith angle and
2638	!-- whether the sun is up
2639	CALL get_date_time( time_since_reference_point, &
2640	day_of_year=day_of_year, &
2641	second_of_day=second_of_day )
2642	CALL calc_zenith( day_of_year, second_of_day )
2643	!
2644	!-- Calculate initial surface albedo for different surfaces
2645	IF ( .NOT. constant_albedo ) THEN
2646	#if defined( __netcdf )
2647	!
2648	!-- Horizontally aligned natural and urban surfaces
2649	CALL calc_albedo( surf_lsm_h )
2650	CALL calc_albedo( surf_usm_h )
2651	!
2652	!-- Vertically aligned natural and urban surfaces
2653	DO l = 0, 3
2654	CALL calc_albedo( surf_lsm_v(l) )
2655	CALL calc_albedo( surf_usm_v(l) )
2656	ENDDO
2657	#endif
2658	ELSE
2659	!
2660	!-- Initialize sun-inclination independent spectral albedos
2661	!-- Horizontal surfaces
2662	IF ( surf_lsm_h%ns > 0 ) THEN
2663	surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir
2664	surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir
2665	surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif
2666	surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif
2667	ENDIF
2668	IF ( surf_usm_h%ns > 0 ) THEN
2669	surf_usm_h%rrtm_aldir = surf_usm_h%aldir
2670	surf_usm_h%rrtm_asdir = surf_usm_h%asdir
2671	surf_usm_h%rrtm_aldif = surf_usm_h%aldif
2672	surf_usm_h%rrtm_asdif = surf_usm_h%asdif
2673	ENDIF
2674	!
2675	!-- Vertical surfaces
2676	DO l = 0, 3
2677	IF ( surf_lsm_v(l)%ns > 0 ) THEN
2678	surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir
2679	surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir
2680	surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif
2681	surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif
2682	ENDIF
2683	IF ( surf_usm_v(l)%ns > 0 ) THEN
2684	surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir
2685	surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir
2686	surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif
2687	surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif
2688	ENDIF
2689	ENDDO
2690
2691	ENDIF
2692
2693	!
2694	!-- Allocate 3d arrays of radiative fluxes and heating rates
2695	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
2696	ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2697	rad_sw_in = 0.0_wp
2698	ENDIF
2699
2700	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
2701	ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2702	ENDIF
2703
2704	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
2705	ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2706	rad_sw_out = 0.0_wp
2707	ENDIF
2708
2709	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
2710	ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2711	ENDIF
2712
2713	IF ( .NOT. ALLOCATED ( rad_sw_hr ) ) THEN
2714	ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2715	rad_sw_hr = 0.0_wp
2716	ENDIF
2717
2718	IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) ) THEN
2719	ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2720	rad_sw_hr_av = 0.0_wp
2721	ENDIF
2722
2723	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) ) THEN
2724	ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2725	rad_sw_cs_hr = 0.0_wp
2726	ENDIF
2727
2728	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) ) THEN
2729	ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2730	rad_sw_cs_hr_av = 0.0_wp
2731	ENDIF
2732
2733	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
2734	ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2735	rad_lw_in = 0.0_wp
2736	ENDIF
2737
2738	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
2739	ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2740	ENDIF
2741
2742	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
2743	ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2744	rad_lw_out = 0.0_wp
2745	ENDIF
2746
2747	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
2748	ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2749	ENDIF
2750
2751	IF ( .NOT. ALLOCATED ( rad_lw_hr ) ) THEN
2752	ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2753	rad_lw_hr = 0.0_wp
2754	ENDIF
2755
2756	IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) ) THEN
2757	ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2758	rad_lw_hr_av = 0.0_wp
2759	ENDIF
2760
2761	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) ) THEN
2762	ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2763	rad_lw_cs_hr = 0.0_wp
2764	ENDIF
2765
2766	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) ) THEN
2767	ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2768	rad_lw_cs_hr_av = 0.0_wp
2769	ENDIF
2770
2771	ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2772	ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2773	rad_sw_cs_in = 0.0_wp
2774	rad_sw_cs_out = 0.0_wp
2775
2776	ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2777	ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2778	rad_lw_cs_in = 0.0_wp
2779	rad_lw_cs_out = 0.0_wp
2780
2781	!
2782	!-- Allocate 1-element array for surface temperature
2783	!-- (RRTMG anticipates an array as passed argument).
2784	ALLOCATE ( rrtm_tsfc(1) )
2785	!
2786	!-- Allocate surface emissivity.
2787	!-- Values will be given directly before calling rrtm_lw.
2788	ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) )
2789
2790	!
2791	!-- Initialize RRTMG, before check if files are existent
2792	INQUIRE( FILE='rrtmg_lw.nc', EXIST=lw_exists )
2793	IF ( .NOT. lw_exists ) THEN
2794	message_string = 'Input file rrtmg_lw.nc' // &
2795	'&for rrtmg missing. ' // &
2796	'&Please provide <jobname>_lsw file in the INPUT directory.'
2797	CALL message( 'radiation_init', 'PA0583', 1, 2, 0, 6, 0 )
2798	ENDIF
2799	INQUIRE( FILE='rrtmg_sw.nc', EXIST=sw_exists )
2800	IF ( .NOT. sw_exists ) THEN
2801	message_string = 'Input file rrtmg_sw.nc' // &
2802	'&for rrtmg missing. ' // &
2803	'&Please provide <jobname>_rsw file in the INPUT directory.'
2804	CALL message( 'radiation_init', 'PA0584', 1, 2, 0, 6, 0 )
2805	ENDIF
2806
2807	IF ( lw_radiation ) CALL rrtmg_lw_ini ( c_p )
2808	IF ( sw_radiation ) CALL rrtmg_sw_ini ( c_p )
2809
2810	!
2811	!-- Set input files for RRTMG
2812	INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists)
2813	IF ( .NOT. snd_exists ) THEN
2814	rrtm_input_file = "rrtmg_lw.nc"
2815	ENDIF
2816
2817	!
2818	!-- Read vertical layers for RRTMG from sounding data
2819	!-- The routine provides nzt_rad, hyp_snd(1:nzt_rad),
2820	!-- t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1),
2821	!-- rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1)
2822	CALL read_sounding_data
2823
2824	!
2825	!-- Read trace gas profiles from file. This routine provides
2826	!-- the rrtm_ arrays (1:nzt_rad+1)
2827	CALL read_trace_gas_data
2828	#endif
2829	ENDIF
2830	!
2831	!-- Initializaion actions exclusively required for external
2832	!-- radiation forcing
2833	IF ( radiation_scheme == 'external' ) THEN
2834	!
2835	!-- Open the radiation input file. Note, for child domain, a dynamic
2836	!-- input file is often not provided. In order to do not need to
2837	!-- duplicate the dynamic input file just for the radiation input, take
2838	!-- it from the dynamic file for the parent if not available for the
2839	!-- child domain(s). In this case this is possible because radiation
2840	!-- input should be the same for each model.
2841	INQUIRE( FILE = TRIM( input_file_dynamic ), &
2842	EXIST = radiation_input_root_domain )
2843
2844	IF ( .NOT. input_pids_dynamic .AND. &
2845	.NOT. radiation_input_root_domain ) THEN
2846	message_string = 'In case of external radiation forcing ' // &
2847	'a dynamic input file is required. If no ' // &
2848	'dynamic input for the child domain(s) is ' // &
2849	'provided, at least one for the root domain ' // &
2850	'is needed.'
2851	CALL message( 'radiation_init', 'PA0315', 1, 2, 0, 6, 0 )
2852	ENDIF
2853	#if defined( __netcdf )
2854	!
2855	!-- Open dynamic input file for child domain if available, else, open
2856	!-- dynamic input file for the root domain.
2857	IF ( input_pids_dynamic ) THEN
2858	CALL open_read_file( TRIM( input_file_dynamic ) // &
2859	TRIM( coupling_char ), &
2860	pids_id )
2861	ELSEIF ( radiation_input_root_domain ) THEN
2862	CALL open_read_file( TRIM( input_file_dynamic ), &
2863	pids_id )
2864	ENDIF
2865
2866	CALL inquire_num_variables( pids_id, num_var_pids )
2867	!
2868	!-- Allocate memory to store variable names and read them
2869	ALLOCATE( vars_pids(1:num_var_pids) )
2870	CALL inquire_variable_names( pids_id, vars_pids )
2871	!
2872	!-- Input time dimension.
2873	IF ( check_existence( vars_pids, 'time_rad' ) ) THEN
2874	CALL get_dimension_length( pids_id, ntime, 'time_rad' )
2875
2876	ALLOCATE( time_rad_f%var1d(0:ntime-1) )
2877	!
2878	!-- Read variable
2879	CALL get_variable( pids_id, 'time_rad', time_rad_f%var1d )
2880
2881	time_rad_f%from_file = .TRUE.
2882	ENDIF
2883	!
2884	!-- Input shortwave downwelling.
2885	IF ( check_existence( vars_pids, 'rad_sw_in' ) ) THEN
2886	!
2887	!-- Get _FillValue attribute
2888	CALL get_attribute( pids_id, char_fill, rad_sw_in_f%fill, &
2889	.FALSE., 'rad_sw_in' )
2890	!
2891	!-- Get level-of-detail
2892	CALL get_attribute( pids_id, char_lod, rad_sw_in_f%lod, &
2893	.FALSE., 'rad_sw_in' )
2894	!
2895	!-- Level-of-detail 1 - radiation depends only on time_rad
2896	IF ( rad_sw_in_f%lod == 1 ) THEN
2897	ALLOCATE( rad_sw_in_f%var1d(0:ntime-1) )
2898	CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var1d )
2899	rad_sw_in_f%from_file = .TRUE.
2900	!
2901	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2902	ELSEIF ( rad_sw_in_f%lod == 2 ) THEN
2903	ALLOCATE( rad_sw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2904
2905	CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var3d, &
2906	nxl, nxr, nys, nyn, 0, ntime-1 )
2907
2908	rad_sw_in_f%from_file = .TRUE.
2909	ELSE
2910	message_string = '"rad_sw_in" has no valid lod attribute'
2911	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2912	ENDIF
2913	ENDIF
2914	!
2915	!-- Input longwave downwelling.
2916	IF ( check_existence( vars_pids, 'rad_lw_in' ) ) THEN
2917	!
2918	!-- Get _FillValue attribute
2919	CALL get_attribute( pids_id, char_fill, rad_lw_in_f%fill, &
2920	.FALSE., 'rad_lw_in' )
2921	!
2922	!-- Get level-of-detail
2923	CALL get_attribute( pids_id, char_lod, rad_lw_in_f%lod, &
2924	.FALSE., 'rad_lw_in' )
2925	!
2926	!-- Level-of-detail 1 - radiation depends only on time_rad
2927	IF ( rad_lw_in_f%lod == 1 ) THEN
2928	ALLOCATE( rad_lw_in_f%var1d(0:ntime-1) )
2929	CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var1d )
2930	rad_lw_in_f%from_file = .TRUE.
2931	!
2932	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2933	ELSEIF ( rad_lw_in_f%lod == 2 ) THEN
2934	ALLOCATE( rad_lw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2935
2936	CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var3d, &
2937	nxl, nxr, nys, nyn, 0, ntime-1 )
2938
2939	rad_lw_in_f%from_file = .TRUE.
2940	ELSE
2941	message_string = '"rad_lw_in" has no valid lod attribute'
2942	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2943	ENDIF
2944	ENDIF
2945	!
2946	!-- Input shortwave downwelling, diffuse part.
2947	IF ( check_existence( vars_pids, 'rad_sw_in_dif' ) ) THEN
2948	!
2949	!-- Read _FillValue attribute
2950	CALL get_attribute( pids_id, char_fill, rad_sw_in_dif_f%fill, &
2951	.FALSE., 'rad_sw_in_dif' )
2952	!
2953	!-- Get level-of-detail
2954	CALL get_attribute( pids_id, char_lod, rad_sw_in_dif_f%lod, &
2955	.FALSE., 'rad_sw_in_dif' )
2956	!
2957	!-- Level-of-detail 1 - radiation depends only on time_rad
2958	IF ( rad_sw_in_dif_f%lod == 1 ) THEN
2959	ALLOCATE( rad_sw_in_dif_f%var1d(0:ntime-1) )
2960	CALL get_variable( pids_id, 'rad_sw_in_dif', &
2961	rad_sw_in_dif_f%var1d )
2962	rad_sw_in_dif_f%from_file = .TRUE.
2963	!
2964	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2965	ELSEIF ( rad_sw_in_dif_f%lod == 2 ) THEN
2966	ALLOCATE( rad_sw_in_dif_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2967
2968	CALL get_variable( pids_id, 'rad_sw_in_dif', &
2969	rad_sw_in_dif_f%var3d, &
2970	nxl, nxr, nys, nyn, 0, ntime-1 )
2971
2972	rad_sw_in_dif_f%from_file = .TRUE.
2973	ELSE
2974	message_string = '"rad_sw_in_dif" has no valid lod attribute'
2975	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2976	ENDIF
2977	ENDIF
2978	!
2979	!-- Finally, close the input file and deallocate temporary arrays
2980	DEALLOCATE( vars_pids )
2981
2982	CALL close_input_file( pids_id )
2983	#endif
2984	!
2985	!-- Make some consistency checks.
2986	IF ( .NOT. rad_sw_in_f%from_file .OR. &
2987	.NOT. rad_lw_in_f%from_file ) THEN
2988	message_string = 'In case of external radiation forcing ' // &
2989	'both, rad_sw_in and rad_lw_in are required.'
2990	CALL message( 'radiation_init', 'PA0195', 1, 2, 0, 6, 0 )
2991	ENDIF
2992
2993	IF ( .NOT. time_rad_f%from_file ) THEN
2994	message_string = 'In case of external radiation forcing ' // &
2995	'dimension time_rad is required.'
2996	CALL message( 'radiation_init', 'PA0196', 1, 2, 0, 6, 0 )
2997	ENDIF
2998
2999	CALL get_date_time( 0.0_wp, second_of_day=second_of_day )
3000
3001	IF ( end_time - spinup_time > time_rad_f%var1d(ntime-1) ) THEN
3002	message_string = 'External radiation forcing does not cover ' // &
3003	'the entire simulation time.'
3004	CALL message( 'radiation_init', 'PA0314', 1, 2, 0, 6, 0 )
3005	ENDIF
3006	!
3007	!-- Check for fill values in radiation
3008	IF ( ALLOCATED( rad_sw_in_f%var1d ) ) THEN
3009	IF ( ANY( rad_sw_in_f%var1d == rad_sw_in_f%fill ) ) THEN
3010	message_string = 'External radiation array "rad_sw_in" ' // &
3011	'must not contain any fill values.'
3012	CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
3013	ENDIF
3014	ENDIF
3015
3016	IF ( ALLOCATED( rad_lw_in_f%var1d ) ) THEN
3017	IF ( ANY( rad_lw_in_f%var1d == rad_lw_in_f%fill ) ) THEN
3018	message_string = 'External radiation array "rad_lw_in" ' // &
3019	'must not contain any fill values.'
3020	CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
3021	ENDIF
3022	ENDIF
3023
3024	IF ( ALLOCATED( rad_sw_in_dif_f%var1d ) ) THEN
3025	IF ( ANY( rad_sw_in_dif_f%var1d == rad_sw_in_dif_f%fill ) ) THEN
3026	message_string = 'External radiation array "rad_sw_in_dif" ' //&
3027	'must not contain any fill values.'
3028	CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
3029	ENDIF
3030	ENDIF
3031
3032	IF ( ALLOCATED( rad_sw_in_f%var3d ) ) THEN
3033	IF ( ANY( rad_sw_in_f%var3d == rad_sw_in_f%fill ) ) THEN
3034	message_string = 'External radiation array "rad_sw_in" ' // &
3035	'must not contain any fill values.'
3036	CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
3037	ENDIF
3038	ENDIF
3039
3040	IF ( ALLOCATED( rad_lw_in_f%var3d ) ) THEN
3041	IF ( ANY( rad_lw_in_f%var3d == rad_lw_in_f%fill ) ) THEN
3042	message_string = 'External radiation array "rad_lw_in" ' // &
3043	'must not contain any fill values.'
3044	CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
3045	ENDIF
3046	ENDIF
3047
3048	IF ( ALLOCATED( rad_sw_in_dif_f%var3d ) ) THEN
3049	IF ( ANY( rad_sw_in_dif_f%var3d == rad_sw_in_dif_f%fill ) ) THEN
3050	message_string = 'External radiation array "rad_sw_in_dif" ' //&
3051	'must not contain any fill values.'
3052	CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
3053	ENDIF
3054	ENDIF
3055	!
3056	!-- Currently, 2D external radiation input is not possible in
3057	!-- combination with topography where average radiation is used.
3058	IF ( ( rad_lw_in_f%lod == 2 .OR. rad_sw_in_f%lod == 2 .OR. &
3059	rad_sw_in_dif_f%lod == 2 ) .AND. average_radiation ) THEN
3060	message_string = 'External radiation with lod = 2 is currently '//&
3061	'not possible with average_radiation = .T..'
3062	CALL message( 'radiation_init', 'PA0670', 1, 2, 0, 6, 0 )
3063	ENDIF
3064	!
3065	!-- All radiation input should have the same level of detail. The sum
3066	!-- of lods divided by the number of available radiation arrays must be
3067	!-- 1 (if all are lod = 1) or 2 (if all are lod = 2).
3068	IF ( REAL( MERGE( rad_lw_in_f%lod, 0, rad_lw_in_f%from_file ) + &
3069	MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
3070	MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
3071	KIND = wp ) / &
3072	( MERGE( 1.0_wp, 0.0_wp, rad_lw_in_f%from_file ) + &
3073	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
3074	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) &
3075	/= 1.0_wp .AND. &
3076	REAL( MERGE( rad_lw_in_f%lod, 0, rad_lw_in_f%from_file ) + &
3077	MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
3078	MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
3079	KIND = wp ) / &
3080	( MERGE( 1.0_wp, 0.0_wp, rad_lw_in_f%from_file ) + &
3081	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
3082	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) &
3083	/= 2.0_wp ) THEN
3084	message_string = 'External radiation input should have the same '//&
3085	'lod.'
3086	CALL message( 'radiation_init', 'PA0673', 1, 2, 0, 6, 0 )
3087	ENDIF
3088
3089	ENDIF
3090	!
3091	!-- Perform user actions if required
3092	CALL user_init_radiation
3093
3094	!
3095	!-- Calculate radiative fluxes at model start
3096	SELECT CASE ( TRIM( radiation_scheme ) )
3097
3098	CASE ( 'rrtmg' )
3099	CALL radiation_rrtmg
3100
3101	CASE ( 'clear-sky' )
3102	CALL radiation_clearsky
3103
3104	CASE ( 'constant' )
3105	CALL radiation_constant
3106
3107	CASE ( 'external' )
3108	!
3109	!-- During spinup apply clear-sky model
3110	IF ( time_since_reference_point < 0.0_wp ) THEN
3111	CALL radiation_clearsky
3112	ELSE
3113	CALL radiation_external
3114	ENDIF
3115
3116	CASE DEFAULT
3117
3118	END SELECT
3119
3120	!
3121	!-- Find all discretized apparent solar positions for radiation interaction.
3122	IF ( radiation_interactions ) CALL radiation_presimulate_solar_pos
3123
3124	!
3125	!-- If required, read or calculate and write out the SVF
3126	IF ( radiation_interactions .AND. read_svf) THEN
3127	!
3128	!-- Read sky-view factors and further required data from file
3129	CALL radiation_read_svf()
3130
3131	ELSEIF ( radiation_interactions .AND. .NOT. read_svf) THEN
3132	!
3133	!-- calculate SFV and CSF
3134	CALL radiation_calc_svf()
3135	ENDIF
3136
3137	IF ( radiation_interactions .AND. write_svf) THEN
3138	!
3139	!-- Write svf, csf svfsurf and csfsurf data to file
3140	CALL radiation_write_svf()
3141	ENDIF
3142
3143	!
3144	!-- Adjust radiative fluxes. In case of urban and land surfaces, also
3145	!-- call an initial interaction.
3146	IF ( radiation_interactions ) THEN
3147	CALL radiation_interaction
3148	ENDIF
3149
3150	IF ( debug_output ) CALL debug_message( 'radiation_init', 'end' )
3151
3152	RETURN !todo: remove, I don't see what we need this for here
3153
3154	END SUBROUTINE radiation_init
3155
3156
3157	!------------------------------------------------------------------------------!
3158	! Description:
3159	! ------------
3160	!> A simple clear sky radiation model
3161	!------------------------------------------------------------------------------!
3162	SUBROUTINE radiation_external
3163
3164	IMPLICIT NONE
3165
3166	INTEGER(iwp) :: l !< running index for surface orientation
3167	INTEGER(iwp) :: t !< index of current timestep
3168	INTEGER(iwp) :: tm !< index of previous timestep
3169
3170	LOGICAL :: horizontal !< flag indicating treatment of horinzontal surfaces
3171
3172	REAL(wp) :: fac_dt !< interpolation factor
3173	REAL(wp) :: second_of_day_init !< second of the day at model start
3174
3175	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3176
3177	!
3178	!-- Calculate current zenith angle
3179	CALL get_date_time( time_since_reference_point, &
3180	day_of_year=day_of_year, &
3181	second_of_day=second_of_day )
3182	CALL calc_zenith( day_of_year, second_of_day )
3183	!
3184	!-- Interpolate external radiation on current timestep
3185	IF ( time_since_reference_point <= 0.0_wp ) THEN
3186	t = 0
3187	tm = 0
3188	fac_dt = 0
3189	ELSE
3190	CALL get_date_time( 0.0_wp, second_of_day=second_of_day_init )
3191	t = 0
3192	DO WHILE ( time_rad_f%var1d(t) <= time_since_reference_point )
3193	t = t + 1
3194	ENDDO
3195
3196	tm = MAX( t-1, 0 )
3197
3198	fac_dt = ( time_since_reference_point &
3199	- time_rad_f%var1d(tm) + dt_3d ) &
3200	/ ( time_rad_f%var1d(t) - time_rad_f%var1d(tm) )
3201	fac_dt = MIN( 1.0_wp, fac_dt )
3202	ENDIF
3203	!
3204	!-- Call clear-sky calculation for each surface orientation.
3205	!-- First, horizontal surfaces
3206	horizontal = .TRUE.
3207	surf => surf_lsm_h
3208	CALL radiation_external_surf
3209	surf => surf_usm_h
3210	CALL radiation_external_surf
3211	horizontal = .FALSE.
3212	!
3213	!-- Vertical surfaces
3214	DO l = 0, 3
3215	surf => surf_lsm_v(l)
3216	CALL radiation_external_surf
3217	surf => surf_usm_v(l)
3218	CALL radiation_external_surf
3219	ENDDO
3220
3221	CONTAINS
3222
3223	SUBROUTINE radiation_external_surf
3224
3225	USE control_parameters
3226
3227	IMPLICIT NONE
3228
3229	INTEGER(iwp) :: i !< grid index along x-dimension
3230	INTEGER(iwp) :: j !< grid index along y-dimension
3231	INTEGER(iwp) :: k !< grid index along z-dimension
3232	INTEGER(iwp) :: m !< running index for surface elements
3233
3234	REAL(wp) :: lw_in !< downwelling longwave radiation, interpolated value
3235	REAL(wp) :: sw_in !< downwelling shortwave radiation, interpolated value
3236	REAL(wp) :: sw_in_dif !< downwelling diffuse shortwave radiation, interpolated value
3237
3238	IF ( surf%ns < 1 ) RETURN
3239	!
3240	!-- level-of-detail = 1. Note, here it must be distinguished between
3241	!-- averaged radiation and non-averaged radiation for the upwelling
3242	!-- fluxes.
3243	IF ( rad_sw_in_f%lod == 1 ) THEN
3244
3245	sw_in = ( 1.0_wp - fac_dt ) * rad_sw_in_f%var1d(tm) &
3246	+ fac_dt * rad_sw_in_f%var1d(t)
3247
3248	lw_in = ( 1.0_wp - fac_dt ) * rad_lw_in_f%var1d(tm) &
3249	+ fac_dt * rad_lw_in_f%var1d(t)
3250	!
3251	!-- Limit shortwave incoming radiation to positive values, in order
3252	!-- to overcome possible observation errors.
3253	sw_in = MAX( 0.0_wp, sw_in )
3254	sw_in = MERGE( sw_in, 0.0_wp, sun_up )
3255
3256	surf%rad_sw_in = sw_in
3257	surf%rad_lw_in = lw_in
3258
3259	IF ( average_radiation ) THEN
3260	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3261
3262	surf%rad_lw_out = emissivity_urb * sigma_sb * t_rad_urb**4 &
3263	+ ( 1.0_wp - emissivity_urb ) * surf%rad_lw_in
3264
3265	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
3266	+ surf%rad_lw_in - surf%rad_lw_out
3267
3268	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb &
3269	* sigma_sb &
3270	* t_rad_urb**3
3271	ELSE
3272	DO m = 1, surf%ns
3273	k = surf%k(m)
3274	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3275	surf%albedo(ind_veg_wall,m) &
3276	+ surf%frac(ind_pav_green,m) * &
3277	surf%albedo(ind_pav_green,m) &
3278	+ surf%frac(ind_wat_win,m) * &
3279	surf%albedo(ind_wat_win,m) ) &
3280	* surf%rad_sw_in(m)
3281
3282	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3283	surf%emissivity(ind_veg_wall,m) &
3284	+ surf%frac(ind_pav_green,m) * &
3285	surf%emissivity(ind_pav_green,m) &
3286	+ surf%frac(ind_wat_win,m) * &
3287	surf%emissivity(ind_wat_win,m) &
3288	) &
3289	* sigma_sb &
3290	* ( surf%pt_surface(m) * exner(k) )**4
3291
3292	surf%rad_lw_out_change_0(m) = &
3293	( surf%frac(ind_veg_wall,m) * &
3294	surf%emissivity(ind_veg_wall,m) &
3295	+ surf%frac(ind_pav_green,m) * &
3296	surf%emissivity(ind_pav_green,m) &
3297	+ surf%frac(ind_wat_win,m) * &
3298	surf%emissivity(ind_wat_win,m) &
3299	) * 4.0_wp * sigma_sb &
3300	* ( surf%pt_surface(m) * exner(k) )**3
3301	ENDDO
3302
3303	ENDIF
3304	!
3305	!-- If diffuse shortwave radiation is available, store it on
3306	!-- the respective files.
3307	IF ( rad_sw_in_dif_f%from_file ) THEN
3308	sw_in_dif= ( 1.0_wp - fac_dt ) * rad_sw_in_dif_f%var1d(tm) &
3309	+ fac_dt * rad_sw_in_dif_f%var1d(t)
3310
3311	IF ( ALLOCATED( rad_sw_in_diff ) ) rad_sw_in_diff = sw_in_dif
3312	IF ( ALLOCATED( rad_sw_in_dir ) ) rad_sw_in_dir = sw_in &
3313	- sw_in_dif
3314	!
3315	!-- Diffuse longwave radiation equals the total downwelling
3316	!-- longwave radiation
3317	IF ( ALLOCATED( rad_lw_in_diff ) ) rad_lw_in_diff = lw_in
3318	ENDIF
3319	!
3320	!-- level-of-detail = 2
3321	ELSE
3322
3323	DO m = 1, surf%ns
3324	i = surf%i(m)
3325	j = surf%j(m)
3326	k = surf%k(m)
3327
3328	surf%rad_sw_in(m) = ( 1.0_wp - fac_dt ) &
3329	* rad_sw_in_f%var3d(tm,j,i) &
3330	+ fac_dt * rad_sw_in_f%var3d(t,j,i)
3331	!
3332	!-- Limit shortwave incoming radiation to positive values, in
3333	!-- order to overcome possible observation errors.
3334	surf%rad_sw_in(m) = MAX( 0.0_wp, surf%rad_sw_in(m) )
3335	surf%rad_sw_in(m) = MERGE( surf%rad_sw_in(m), 0.0_wp, sun_up )
3336
3337	surf%rad_lw_in(m) = ( 1.0_wp - fac_dt ) &
3338	* rad_lw_in_f%var3d(tm,j,i) &
3339	+ fac_dt * rad_lw_in_f%var3d(t,j,i)
3340	!
3341	!-- Weighted average according to surface fraction.
3342	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3343	surf%albedo(ind_veg_wall,m) &
3344	+ surf%frac(ind_pav_green,m) * &
3345	surf%albedo(ind_pav_green,m) &
3346	+ surf%frac(ind_wat_win,m) * &
3347	surf%albedo(ind_wat_win,m) ) &
3348	* surf%rad_sw_in(m)
3349
3350	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3351	surf%emissivity(ind_veg_wall,m) &
3352	+ surf%frac(ind_pav_green,m) * &
3353	surf%emissivity(ind_pav_green,m) &
3354	+ surf%frac(ind_wat_win,m) * &
3355	surf%emissivity(ind_wat_win,m) &
3356	) &
3357	* sigma_sb &
3358	* ( surf%pt_surface(m) * exner(k) )**4
3359
3360	surf%rad_lw_out_change_0(m) = &
3361	( surf%frac(ind_veg_wall,m) * &
3362	surf%emissivity(ind_veg_wall,m) &
3363	+ surf%frac(ind_pav_green,m) * &
3364	surf%emissivity(ind_pav_green,m) &
3365	+ surf%frac(ind_wat_win,m) * &
3366	surf%emissivity(ind_wat_win,m) &
3367	) * 4.0_wp * sigma_sb &
3368	* ( surf%pt_surface(m) * exner(k) )**3
3369
3370	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
3371	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
3372	!
3373	!-- If diffuse shortwave radiation is available, store it on
3374	!-- the respective files.
3375	IF ( rad_sw_in_dif_f%from_file ) THEN
3376	IF ( ALLOCATED( rad_sw_in_diff ) ) &
3377	rad_sw_in_diff(j,i) = ( 1.0_wp - fac_dt ) &
3378	* rad_sw_in_dif_f%var3d(tm,j,i) &
3379	+ fac_dt * rad_sw_in_dif_f%var3d(t,j,i)
3380	!
3381	!-- dir = sw_in - sw_in_dif.
3382	IF ( ALLOCATED( rad_sw_in_dir ) ) &
3383	rad_sw_in_dir(j,i) = surf%rad_sw_in(m) - &
3384	rad_sw_in_diff(j,i)
3385	!
3386	!-- Diffuse longwave radiation equals the total downwelling
3387	!-- longwave radiation
3388	IF ( ALLOCATED( rad_lw_in_diff ) ) &
3389	rad_lw_in_diff(j,i) = surf%rad_lw_in(m)
3390	ENDIF
3391
3392	ENDDO
3393
3394	ENDIF
3395	!
3396	!-- Store radiation also on 2D arrays, which are still used for
3397	!-- direct-diffuse splitting. Note, this is only required
3398	!-- for horizontal surfaces, which covers all x,y position.
3399	IF ( horizontal ) THEN
3400	DO m = 1, surf%ns
3401	i = surf%i(m)
3402	j = surf%j(m)
3403
3404	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3405	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3406	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3407	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3408	ENDDO
3409	ENDIF
3410
3411	END SUBROUTINE radiation_external_surf
3412
3413	END SUBROUTINE radiation_external
3414
3415	!------------------------------------------------------------------------------!
3416	! Description:
3417	! ------------
3418	!> A simple clear sky radiation model
3419	!------------------------------------------------------------------------------!
3420	SUBROUTINE radiation_clearsky
3421
3422	IMPLICIT NONE
3423
3424	INTEGER(iwp) :: l !< running index for surface orientation
3425
3426	LOGICAL :: horizontal !< flag indicating treatment of horinzontal surfaces
3427
3428	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
3429	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3430	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
3431	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3432
3433	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3434
3435	!
3436	!-- Calculate current zenith angle
3437	CALL get_date_time( time_since_reference_point, &
3438	day_of_year=day_of_year, &
3439	second_of_day=second_of_day )
3440	CALL calc_zenith( day_of_year, second_of_day )
3441
3442	!
3443	!-- Calculate sky transmissivity
3444	sky_trans = 0.6_wp + 0.2_wp * cos_zenith
3445
3446	!
3447	!-- Calculate value of the Exner function at model surface
3448	!
3449	!-- In case averaged radiation is used, calculate mean temperature and
3450	!-- liquid water mixing ratio at the urban-layer top.
3451	IF ( average_radiation ) THEN
3452	pt1 = 0.0_wp
3453	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp
3454
3455	pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3456	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3457
3458	#if defined( __parallel )
3459	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
3460	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3461	IF ( ierr /= 0 ) THEN
3462	WRITE(9,*) 'Error MPI_AllReduce1:', ierr, pt1_l, pt1
3463	FLUSH(9)
3464	ENDIF
3465
3466	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3467	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3468	IF ( ierr /= 0 ) THEN
3469	WRITE(9,*) 'Error MPI_AllReduce2:', ierr, ql1_l, ql1
3470	FLUSH(9)
3471	ENDIF
3472	ENDIF
3473	#else
3474	pt1 = pt1_l
3475	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l
3476	#endif
3477
3478	IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t) * ql1
3479	!
3480	!-- Finally, divide by number of grid points
3481	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3482	ENDIF
3483	!
3484	!-- Call clear-sky calculation for each surface orientation.
3485	!-- First, horizontal surfaces
3486	horizontal = .TRUE.
3487	surf => surf_lsm_h
3488	CALL radiation_clearsky_surf
3489	surf => surf_usm_h
3490	CALL radiation_clearsky_surf
3491	horizontal = .FALSE.
3492	!
3493	!-- Vertical surfaces
3494	DO l = 0, 3
3495	surf => surf_lsm_v(l)
3496	CALL radiation_clearsky_surf
3497	surf => surf_usm_v(l)
3498	CALL radiation_clearsky_surf
3499	ENDDO
3500
3501	CONTAINS
3502
3503	SUBROUTINE radiation_clearsky_surf
3504
3505	IMPLICIT NONE
3506
3507	INTEGER(iwp) :: i !< index x-direction
3508	INTEGER(iwp) :: j !< index y-direction
3509	INTEGER(iwp) :: k !< index z-direction
3510	INTEGER(iwp) :: m !< running index for surface elements
3511
3512	IF ( surf%ns < 1 ) RETURN
3513
3514	!
3515	!-- Calculate radiation fluxes and net radiation (rad_net) assuming
3516	!-- homogeneous urban radiation conditions.
3517	IF ( average_radiation ) THEN
3518
3519	k = nz_urban_t
3520
3521	surf%rad_sw_in = solar_constant * sky_trans * cos_zenith
3522	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3523
3524	surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k+1))**4
3525
3526	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
3527	+ (1.0_wp - emissivity_urb) * surf%rad_lw_in
3528
3529	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
3530	+ surf%rad_lw_in - surf%rad_lw_out
3531
3532	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb &
3533	* (t_rad_urb)**3
3534
3535	!
3536	!-- Calculate radiation fluxes and net radiation (rad_net) for each surface
3537	!-- element.
3538	ELSE
3539
3540	DO m = 1, surf%ns
3541	i = surf%i(m)
3542	j = surf%j(m)
3543	k = surf%k(m)
3544
3545	surf%rad_sw_in(m) = solar_constant * sky_trans * cos_zenith
3546
3547	!
3548	!-- Weighted average according to surface fraction.
3549	!-- ATTENTION: when radiation interactions are switched on the
3550	!-- calculated fluxes below are not actually used as they are
3551	!-- overwritten in radiation_interaction.
3552	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3553	surf%albedo(ind_veg_wall,m) &
3554	+ surf%frac(ind_pav_green,m) * &
3555	surf%albedo(ind_pav_green,m) &
3556	+ surf%frac(ind_wat_win,m) * &
3557	surf%albedo(ind_wat_win,m) ) &
3558	* surf%rad_sw_in(m)
3559
3560	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3561	surf%emissivity(ind_veg_wall,m) &
3562	+ surf%frac(ind_pav_green,m) * &
3563	surf%emissivity(ind_pav_green,m) &
3564	+ surf%frac(ind_wat_win,m) * &
3565	surf%emissivity(ind_wat_win,m) &
3566	) &
3567	* sigma_sb &
3568	* ( surf%pt_surface(m) * exner(nzb) )**4
3569
3570	surf%rad_lw_out_change_0(m) = &
3571	( surf%frac(ind_veg_wall,m) * &
3572	surf%emissivity(ind_veg_wall,m) &
3573	+ surf%frac(ind_pav_green,m) * &
3574	surf%emissivity(ind_pav_green,m) &
3575	+ surf%frac(ind_wat_win,m) * &
3576	surf%emissivity(ind_wat_win,m) &
3577	) * 4.0_wp * sigma_sb &
3578	* ( surf%pt_surface(m) * exner(nzb) )** 3
3579
3580
3581	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3582	pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3583	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3584	ELSE
3585	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt(k,j,i) * exner(k))**4
3586	ENDIF
3587
3588	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
3589	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
3590
3591	ENDDO
3592
3593	ENDIF
3594
3595	!
3596	!-- Fill out values in radiation arrays. Note, this is only required
3597	!-- for horizontal surfaces, which covers all x,y position.
3598	IF ( horizontal ) THEN
3599	DO m = 1, surf%ns
3600	i = surf%i(m)
3601	j = surf%j(m)
3602	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3603	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3604	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3605	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3606	ENDDO
3607	ENDIF
3608
3609	END SUBROUTINE radiation_clearsky_surf
3610
3611	END SUBROUTINE radiation_clearsky
3612
3613
3614	!------------------------------------------------------------------------------!
3615	! Description:
3616	! ------------
3617	!> This scheme keeps the prescribed net radiation constant during the run
3618	!------------------------------------------------------------------------------!
3619	SUBROUTINE radiation_constant
3620
3621
3622	IMPLICIT NONE
3623
3624	INTEGER(iwp) :: l !< running index for surface orientation
3625
3626	LOGICAL :: horizontal !< flag indicating treatment of horinzontal surfaces
3627
3628	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
3629	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3630	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
3631	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3632
3633	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3634
3635	!
3636	!-- In case averaged radiation is used, calculate mean temperature and
3637	!-- liquid water mixing ratio at the urban-layer top.
3638	IF ( average_radiation ) THEN
3639	pt1 = 0.0_wp
3640	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp
3641
3642	pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3643	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3644
3645	#if defined( __parallel )
3646	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
3647	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3648	IF ( ierr /= 0 ) THEN
3649	WRITE(9,*) 'Error MPI_AllReduce3:', ierr, pt1_l, pt1
3650	FLUSH(9)
3651	ENDIF
3652	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3653	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3654	IF ( ierr /= 0 ) THEN
3655	WRITE(9,*) 'Error MPI_AllReduce4:', ierr, ql1_l, ql1
3656	FLUSH(9)
3657	ENDIF
3658	ENDIF
3659	#else
3660	pt1 = pt1_l
3661	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l
3662	#endif
3663	IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t+1) * ql1
3664	!
3665	!-- Finally, divide by number of grid points
3666	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3667	ENDIF
3668
3669	!
3670	!-- First, horizontal surfaces
3671	horizontal = .TRUE.
3672	surf => surf_lsm_h
3673	CALL radiation_constant_surf
3674	surf => surf_usm_h
3675	CALL radiation_constant_surf
3676	horizontal = .FALSE.
3677	!
3678	!-- Vertical surfaces
3679	DO l = 0, 3
3680	surf => surf_lsm_v(l)
3681	CALL radiation_constant_surf
3682	surf => surf_usm_v(l)
3683	CALL radiation_constant_surf
3684	ENDDO
3685
3686	CONTAINS
3687
3688	SUBROUTINE radiation_constant_surf
3689
3690	IMPLICIT NONE
3691
3692	INTEGER(iwp) :: i !< index x-direction
3693	INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x
3694	INTEGER(iwp) :: j !< index y-direction
3695	INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y
3696	INTEGER(iwp) :: k !< index z-direction
3697	INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z
3698	INTEGER(iwp) :: m !< running index for surface elements
3699
3700	IF ( surf%ns < 1 ) RETURN
3701
3702	!-- Calculate homogenoeus urban radiation fluxes
3703	IF ( average_radiation ) THEN
3704
3705	surf%rad_net = net_radiation
3706
3707	surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(nz_urban_t+1))**4
3708
3709	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
3710	+ ( 1.0_wp - emissivity_urb ) & ! shouldn't be this a bulk value -- emissivity_urb?
3711	* surf%rad_lw_in
3712
3713	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb &
3714	* t_rad_urb**3
3715
3716	surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in &
3717	+ surf%rad_lw_out ) &
3718	/ ( 1.0_wp - albedo_urb )
3719
3720	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3721
3722	!
3723	!-- Calculate radiation fluxes for each surface element
3724	ELSE
3725	!
3726	!-- Determine index offset between surface element and adjacent
3727	!-- atmospheric grid point
3728	ioff = surf%ioff
3729	joff = surf%joff
3730	koff = surf%koff
3731
3732	!
3733	!-- Prescribe net radiation and estimate the remaining radiative fluxes
3734	DO m = 1, surf%ns
3735	i = surf%i(m)
3736	j = surf%j(m)
3737	k = surf%k(m)
3738
3739	surf%rad_net(m) = net_radiation
3740
3741	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3742	pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3743	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3744	ELSE
3745	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * &
3746	( pt(k,j,i) * exner(k) )**4
3747	ENDIF
3748
3749	!
3750	!-- Weighted average according to surface fraction.
3751	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3752	surf%emissivity(ind_veg_wall,m) &
3753	+ surf%frac(ind_pav_green,m) * &
3754	surf%emissivity(ind_pav_green,m) &
3755	+ surf%frac(ind_wat_win,m) * &
3756	surf%emissivity(ind_wat_win,m) &
3757	) &
3758	* sigma_sb &
3759	* ( surf%pt_surface(m) * exner(nzb) )**4
3760
3761	surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) &
3762	+ surf%rad_lw_out(m) ) &
3763	/ ( 1.0_wp - &
3764	( surf%frac(ind_veg_wall,m) * &
3765	surf%albedo(ind_veg_wall,m) &
3766	+ surf%frac(ind_pav_green,m) * &
3767	surf%albedo(ind_pav_green,m) &
3768	+ surf%frac(ind_wat_win,m) * &
3769	surf%albedo(ind_wat_win,m) ) &
3770	)
3771
3772	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3773	surf%albedo(ind_veg_wall,m) &
3774	+ surf%frac(ind_pav_green,m) * &
3775	surf%albedo(ind_pav_green,m) &
3776	+ surf%frac(ind_wat_win,m) * &
3777	surf%albedo(ind_wat_win,m) ) &
3778	* surf%rad_sw_in(m)
3779
3780	ENDDO
3781
3782	ENDIF
3783
3784	!
3785	!-- Fill out values in radiation arrays. Note, this is only required
3786	!-- for horizontal surfaces, which covers all x,y position.
3787	IF ( horizontal ) THEN
3788	DO m = 1, surf%ns
3789	i = surf%i(m)
3790	j = surf%j(m)
3791	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3792	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3793	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3794	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3795	ENDDO
3796	ENDIF
3797
3798	END SUBROUTINE radiation_constant_surf
3799
3800
3801	END SUBROUTINE radiation_constant
3802
3803	!------------------------------------------------------------------------------!
3804	! Description:
3805	! ------------
3806	!> Header output for radiation model
3807	!------------------------------------------------------------------------------!
3808	SUBROUTINE radiation_header ( io )
3809
3810
3811	IMPLICIT NONE
3812
3813	INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file
3814
3815
3816
3817	!
3818	!-- Write radiation model header
3819	WRITE( io, 3 )
3820
3821	IF ( radiation_scheme == "constant" ) THEN
3822	WRITE( io, 4 ) net_radiation
3823	ELSEIF ( radiation_scheme == "clear-sky" ) THEN
3824	WRITE( io, 5 )
3825	ELSEIF ( radiation_scheme == "rrtmg" ) THEN
3826	WRITE( io, 6 )
3827	IF ( .NOT. lw_radiation ) WRITE( io, 10 )
3828	IF ( .NOT. sw_radiation ) WRITE( io, 11 )
3829	ELSEIF ( radiation_scheme == "external" ) THEN
3830	WRITE( io, 14 )
3831	ENDIF
3832
3833	IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. &
3834	pavement_type_f%from_file .OR. water_type_f%from_file .OR. &
3835	building_type_f%from_file ) THEN
3836	WRITE( io, 13 )
3837	ELSE
3838	IF ( albedo_type == 0 ) THEN
3839	WRITE( io, 7 ) albedo
3840	ELSE
3841	WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) )
3842	ENDIF
3843	ENDIF
3844	IF ( constant_albedo ) THEN
3845	WRITE( io, 9 )
3846	ENDIF
3847
3848	WRITE( io, 12 ) dt_radiation
3849
3850
3851	3 FORMAT (//' Radiation model information:'/ &
3852	' ----------------------------'/)
3853	4 FORMAT (' --> Using constant net radiation: net_radiation = ', F6.2, &
3854	// 'W/m**2')
3855	5 FORMAT (' --> Simple radiation scheme for clear sky is used (no clouds,',&
3856	' default)')
3857	6 FORMAT (' --> RRTMG scheme is used')
3858	7 FORMAT (/' User-specific surface albedo: albedo =', F6.3)
3859	8 FORMAT (/' Albedo is set for land surface type: ', A)
3860	9 FORMAT (/' --> Albedo is fixed during the run')
3861	10 FORMAT (/' --> Longwave radiation is disabled')
3862	11 FORMAT (/' --> Shortwave radiation is disabled.')
3863	12 FORMAT (' Timestep: dt_radiation = ', F6.2, ' s')
3864	13 FORMAT (/' Albedo is set individually for each xy-location, according ', &
3865	'to given surface type.')
3866	14 FORMAT (' --> External radiation forcing is used')
3867
3868
3869	END SUBROUTINE radiation_header
3870
3871
3872	!------------------------------------------------------------------------------!
3873	! Description:
3874	! ------------
3875	!> Parin for &radiation_parameters for radiation model and RTM
3876	!------------------------------------------------------------------------------!
3877	SUBROUTINE radiation_parin
3878
3879
3880	IMPLICIT NONE
3881
3882	CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file
3883
3884	NAMELIST /radiation_par/ albedo, albedo_lw_dif, albedo_lw_dir, &
3885	albedo_sw_dif, albedo_sw_dir, albedo_type, &
3886	constant_albedo, dt_radiation, emissivity, &
3887	lw_radiation, max_raytracing_dist, &
3888	min_irrf_value, mrt_geom, mrt_geom_params, &
3889	mrt_include_sw, mrt_nlevels, &
3890	mrt_skip_roof, net_radiation, nrefsteps, &
3891	plant_lw_interact, rad_angular_discretization,&
3892	radiation_interactions_on, radiation_scheme, &
3893	raytrace_discrete_azims, &
3894	raytrace_discrete_elevs, raytrace_mpi_rma, &
3895	trace_fluxes_above, &
3896	skip_time_do_radiation, surface_reflections, &
3897	svfnorm_report_thresh, sw_radiation, &
3898	unscheduled_radiation_calls
3899
3900
3901	NAMELIST /radiation_parameters/ albedo, albedo_lw_dif, albedo_lw_dir, &
3902	albedo_sw_dif, albedo_sw_dir, albedo_type, &
3903	constant_albedo, dt_radiation, emissivity, &
3904	lw_radiation, max_raytracing_dist, &
3905	min_irrf_value, mrt_geom, mrt_geom_params, &
3906	mrt_include_sw, mrt_nlevels, &
3907	mrt_skip_roof, net_radiation, nrefsteps, &
3908	plant_lw_interact, rad_angular_discretization,&
3909	radiation_interactions_on, radiation_scheme, &
3910	raytrace_discrete_azims, &
3911	raytrace_discrete_elevs, raytrace_mpi_rma, &
3912	trace_fluxes_above, &
3913	skip_time_do_radiation, surface_reflections, &
3914	svfnorm_report_thresh, sw_radiation, &
3915	unscheduled_radiation_calls
3916
3917	line = ' '
3918
3919	!
3920	!-- Try to find radiation model namelist
3921	REWIND ( 11 )
3922	line = ' '
3923	DO WHILE ( INDEX( line, '&radiation_parameters' ) == 0 )
3924	READ ( 11, '(A)', END=12 ) line
3925	ENDDO
3926	BACKSPACE ( 11 )
3927
3928	!
3929	!-- Read user-defined namelist
3930	READ ( 11, radiation_parameters, ERR = 10 )
3931
3932	!
3933	!-- Set flag that indicates that the radiation model is switched on
3934	radiation = .TRUE.
3935
3936	GOTO 14
3937
3938	10 BACKSPACE( 11 )
3939	READ( 11 , '(A)') line
3940	CALL parin_fail_message( 'radiation_parameters', line )
3941	!
3942	!-- Try to find old namelist
3943	12 REWIND ( 11 )
3944	line = ' '
3945	DO WHILE ( INDEX( line, '&radiation_par' ) == 0 )
3946	READ ( 11, '(A)', END=14 ) line
3947	ENDDO
3948	BACKSPACE ( 11 )
3949
3950	!
3951	!-- Read user-defined namelist
3952	READ ( 11, radiation_par, ERR = 13, END = 14 )
3953
3954	message_string = 'namelist radiation_par is deprecated and will be ' // &
3955	'removed in near future. Please use namelist ' // &
3956	'radiation_parameters instead'
3957	CALL message( 'radiation_parin', 'PA0487', 0, 1, 0, 6, 0 )
3958
3959	!
3960	!-- Set flag that indicates that the radiation model is switched on
3961	radiation = .TRUE.
3962
3963	IF ( .NOT. radiation_interactions_on .AND. surface_reflections ) THEN
3964	message_string = 'surface_reflections is allowed only when ' // &
3965	'radiation_interactions_on is set to TRUE'
3966	CALL message( 'radiation_parin', 'PA0293',1, 2, 0, 6, 0 )
3967	ENDIF
3968
3969	GOTO 14
3970
3971	13 BACKSPACE( 11 )
3972	READ( 11 , '(A)') line
3973	CALL parin_fail_message( 'radiation_par', line )
3974
3975	14 CONTINUE
3976
3977	END SUBROUTINE radiation_parin
3978
3979
3980	!------------------------------------------------------------------------------!
3981	! Description:
3982	! ------------
3983	!> Implementation of the RRTMG radiation_scheme
3984	!------------------------------------------------------------------------------!
3985	SUBROUTINE radiation_rrtmg
3986
3987	#if defined ( __rrtmg )
3988	USE indices, &
3989	ONLY: nbgp
3990
3991	USE palm_date_time_mod, &
3992	ONLY: hours_per_day
3993
3994	USE particle_attributes, &
3995	ONLY: grid_particles, number_of_particles, particles, prt_count
3996
3997	IMPLICIT NONE
3998
3999
4000	INTEGER(iwp) :: i, j, k, l, m, n !< loop indices
4001	INTEGER(iwp) :: k_topo_l !< topography top index
4002	INTEGER(iwp) :: k_topo !< topography top index
4003
4004	REAL(wp) :: d_hours_day !< 1 / hours-per-day
4005	REAL(wp) :: nc_rad, & !< number concentration of cloud droplets
4006	s_r2, & !< weighted sum over all droplets with r^2
4007	s_r3 !< weighted sum over all droplets with r^3
4008
4009	REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av
4010	REAL(wp), DIMENSION(0:0) :: zenith !< to provide indexed array
4011	!
4012	!-- Just dummy arguments
4013	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, &
4014	rrtm_lw_tauaer_dum, &
4015	rrtm_sw_taucld_dum, &
4016	rrtm_sw_ssacld_dum, &
4017	rrtm_sw_asmcld_dum, &
4018	rrtm_sw_fsfcld_dum, &
4019	rrtm_sw_tauaer_dum, &
4020	rrtm_sw_ssaaer_dum, &
4021	rrtm_sw_asmaer_dum, &
4022	rrtm_sw_ecaer_dum
4023
4024	!
4025	!-- Pre-calculate parameters
4026	d_hours_day = 1.0_wp / REAL( hours_per_day, KIND=wp )
4027
4028	!
4029	!-- Calculate current (cosine of) zenith angle and whether the sun is up
4030	CALL get_date_time( time_since_reference_point, &
4031	day_of_year=day_of_year, &
4032	second_of_day=second_of_day )
4033	CALL calc_zenith( day_of_year, second_of_day )
4034	zenith(0) = cos_zenith
4035	!
4036	!-- Calculate surface albedo. In case average radiation is applied,
4037	!-- this is not required.
4038	#if defined( __netcdf )
4039	IF ( .NOT. constant_albedo ) THEN
4040	!
4041	!-- Horizontally aligned default, natural and urban surfaces
4042	CALL calc_albedo( surf_lsm_h )
4043	CALL calc_albedo( surf_usm_h )
4044	!
4045	!-- Vertically aligned default, natural and urban surfaces
4046	DO l = 0, 3
4047	CALL calc_albedo( surf_lsm_v(l) )
4048	CALL calc_albedo( surf_usm_v(l) )
4049	ENDDO
4050	ENDIF
4051	#endif
4052
4053	!
4054	!-- Prepare input data for RRTMG
4055
4056	!
4057	!-- In case of large scale forcing with surface data, calculate new pressure
4058	!-- profile. nzt_rad might be modified by these calls and all required arrays
4059	!-- will then be re-allocated
4060	IF ( large_scale_forcing .AND. lsf_surf ) THEN
4061	CALL read_sounding_data
4062	CALL read_trace_gas_data
4063	ENDIF
4064
4065
4066	IF ( average_radiation ) THEN
4067	!
4068	!-- Determine minimum topography top index.
4069	k_topo_l = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
4070	#if defined( __parallel )
4071	CALL MPI_ALLREDUCE( k_topo_l, k_topo, 1, MPI_INTEGER, MPI_MIN, &
4072	comm2d, ierr)
4073	#else
4074	k_topo = k_topo_l
4075	#endif
4076
4077	rrtm_asdir(1) = albedo_urb
4078	rrtm_asdif(1) = albedo_urb
4079	rrtm_aldir(1) = albedo_urb
4080	rrtm_aldif(1) = albedo_urb
4081
4082	rrtm_emis = emissivity_urb
4083	!
4084	!-- Calculate mean pt profile.
4085	CALL calc_mean_profile( pt, 4 )
4086	pt_av = hom(:, 1, 4, 0)
4087
4088	IF ( humidity ) THEN
4089	CALL calc_mean_profile( q, 41 )
4090	q_av = hom(:, 1, 41, 0)
4091	ENDIF
4092	!
4093	!-- Prepare profiles of temperature and H2O volume mixing ratio
4094	rrtm_tlev(0,k_topo+1) = t_rad_urb
4095
4096	IF ( bulk_cloud_model ) THEN
4097
4098	CALL calc_mean_profile( ql, 54 )
4099	! average ql is now in hom(:, 1, 54, 0)
4100	ql_av = hom(:, 1, 54, 0)
4101
4102	DO k = nzb+1, nzt+1
4103	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
4104	)*.286_wp + lv_d_cp ql_av(k)
4105	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k))
4106	ENDDO
4107	ELSE
4108	DO k = nzb+1, nzt+1
4109	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
4110	)**.286_wp
4111	ENDDO
4112
4113	IF ( humidity ) THEN
4114	DO k = nzb+1, nzt+1
4115	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q_av(k)
4116	ENDDO
4117	ELSE
4118	rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
4119	ENDIF
4120	ENDIF
4121
4122	!
4123	!-- Avoid temperature/humidity jumps at the top of the PALM domain by
4124	!-- linear interpolation from nzt+2 to nzt+7. Jumps are induced by
4125	!-- discrepancies between the values in the domain and those above that
4126	!-- are prescribed in RRTMG
4127	DO k = nzt+2, nzt+7
4128	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
4129	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
4130	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
4131	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4132
4133	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
4134	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
4135	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
4136	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4137
4138	ENDDO
4139
4140	!-- Linear interpolate to zw grid. Loop reaches one level further up
4141	!-- due to the staggered grid in RRTMG
4142	DO k = k_topo+2, nzt+8
4143	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
4144	rrtm_tlay(0,k-1)) &
4145	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4146	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4147	ENDDO
4148	!
4149	!-- Calculate liquid water path and cloud fraction for each column.
4150	!-- Note that LWP is required in g/m2 instead of kg/kg m.
4151	rrtm_cldfr = 0.0_wp
4152	rrtm_reliq = 0.0_wp
4153	rrtm_cliqwp = 0.0_wp
4154	rrtm_icld = 0
4155
4156	IF ( bulk_cloud_model ) THEN
4157	DO k = nzb+1, nzt+1
4158	rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * &
4159	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
4160	* 100._wp / g
4161
4162	IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN
4163	rrtm_cldfr(0,k) = 1._wp
4164	IF ( rrtm_icld == 0 ) rrtm_icld = 1
4165
4166	!
4167	!-- Calculate cloud droplet effective radius
4168	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql_av(k) &
4169	* rho_surface &
4170	/ ( 4.0_wp * pi * nc_const * rho_l ) &
4171	)**0.33333333333333_wp &
4172	* EXP( LOG( sigma_gc )**2 )
4173	!
4174	!-- Limit effective radius
4175	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
4176	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
4177	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
4178	ENDIF
4179	ENDIF
4180	ENDDO
4181	ENDIF
4182
4183	!
4184	!-- Set surface temperature
4185	rrtm_tsfc = t_rad_urb
4186
4187	IF ( lw_radiation ) THEN
4188	!
4189	!-- Due to technical reasons, copy optical depth to dummy arguments
4190	!-- which are allocated on the exact size as the rrtmg_lw is called.
4191	!-- As one dimesion is allocated with zero size, compiler complains
4192	!-- that rank of the array does not match that of the
4193	!-- assumed-shaped arguments in the RRTMG library. In order to
4194	!-- avoid this, write to dummy arguments and give pass the entire
4195	!-- dummy array. Seems to be the only existing work-around.
4196	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
4197	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
4198
4199	rrtm_lw_taucld_dum = &
4200	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
4201	rrtm_lw_tauaer_dum = &
4202	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
4203
4204	CALL rrtmg_lw( 1, &
4205	nzt_rad-k_topo, &
4206	rrtm_icld, &
4207	rrtm_idrv, &
4208	rrtm_play(:,k_topo+1:), &
4209	rrtm_plev(:,k_topo+1:), &
4210	rrtm_tlay(:,k_topo+1:), &
4211	rrtm_tlev(:,k_topo+1:), &
4212	rrtm_tsfc, &
4213	rrtm_h2ovmr(:,k_topo+1:), &
4214	rrtm_o3vmr(:,k_topo+1:), &
4215	rrtm_co2vmr(:,k_topo+1:), &
4216	rrtm_ch4vmr(:,k_topo+1:), &
4217	rrtm_n2ovmr(:,k_topo+1:), &
4218	rrtm_o2vmr(:,k_topo+1:), &
4219	rrtm_cfc11vmr(:,k_topo+1:), &
4220	rrtm_cfc12vmr(:,k_topo+1:), &
4221	rrtm_cfc22vmr(:,k_topo+1:), &
4222	rrtm_ccl4vmr(:,k_topo+1:), &
4223	rrtm_emis, &
4224	rrtm_inflglw, &
4225	rrtm_iceflglw, &
4226	rrtm_liqflglw, &
4227	rrtm_cldfr(:,k_topo+1:), &
4228	rrtm_lw_taucld_dum, &
4229	rrtm_cicewp(:,k_topo+1:), &
4230	rrtm_cliqwp(:,k_topo+1:), &
4231	rrtm_reice(:,k_topo+1:), &
4232	rrtm_reliq(:,k_topo+1:), &
4233	rrtm_lw_tauaer_dum, &
4234	rrtm_lwuflx(:,k_topo:), &
4235	rrtm_lwdflx(:,k_topo:), &
4236	rrtm_lwhr(:,k_topo+1:), &
4237	rrtm_lwuflxc(:,k_topo:), &
4238	rrtm_lwdflxc(:,k_topo:), &
4239	rrtm_lwhrc(:,k_topo+1:), &
4240	rrtm_lwuflx_dt(:,k_topo:), &
4241	rrtm_lwuflxc_dt(:,k_topo:) )
4242
4243	DEALLOCATE ( rrtm_lw_taucld_dum )
4244	DEALLOCATE ( rrtm_lw_tauaer_dum )
4245	!
4246	!-- Save fluxes
4247	DO k = nzb, nzt+1
4248	rad_lw_in(k,:,:) = rrtm_lwdflx(0,k)
4249	rad_lw_out(k,:,:) = rrtm_lwuflx(0,k)
4250	ENDDO
4251	rad_lw_in_diff(:,:) = rad_lw_in(k_topo,:,:)
4252	!
4253	!-- Save heating rates (convert from K/d to K/h).
4254	!-- Further, even though an aggregated radiation is computed, map
4255	!-- signle-column profiles on top of any topography, in order to
4256	!-- obtain correct near surface radiation heating/cooling rates.
4257	DO i = nxl, nxr
4258	DO j = nys, nyn
4259	k_topo_l = topo_top_ind(j,i,0)
4260	DO k = k_topo_l+1, nzt+1
4261	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo_l) * d_hours_day
4262	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo_l) * d_hours_day
4263	ENDDO
4264	ENDDO
4265	ENDDO
4266
4267	ENDIF
4268
4269	IF ( sw_radiation .AND. sun_up ) THEN
4270	!
4271	!-- Due to technical reasons, copy optical depths and other
4272	!-- to dummy arguments which are allocated on the exact size as the
4273	!-- rrtmg_sw is called.
4274	!-- As one dimesion is allocated with zero size, compiler complains
4275	!-- that rank of the array does not match that of the
4276	!-- assumed-shaped arguments in the RRTMG library. In order to
4277	!-- avoid this, write to dummy arguments and give pass the entire
4278	!-- dummy array. Seems to be the only existing work-around.
4279	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4280	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4281	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4282	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4283	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4284	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4285	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4286	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
4287
4288	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4289	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4290	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4291	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4292	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4293	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4294	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4295	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
4296
4297	CALL rrtmg_sw( 1, &
4298	nzt_rad-k_topo, &
4299	rrtm_icld, &
4300	rrtm_iaer, &
4301	rrtm_play(:,k_topo+1:nzt_rad+1), &
4302	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4303	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4304	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4305	rrtm_tsfc, &
4306	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4307	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4308	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4309	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4310	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4311	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4312	rrtm_asdir, &
4313	rrtm_asdif, &
4314	rrtm_aldir, &
4315	rrtm_aldif, &
4316	zenith, &
4317	0.0_wp, &
4318	day_of_year, &
4319	solar_constant, &
4320	rrtm_inflgsw, &
4321	rrtm_iceflgsw, &
4322	rrtm_liqflgsw, &
4323	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4324	rrtm_sw_taucld_dum, &
4325	rrtm_sw_ssacld_dum, &
4326	rrtm_sw_asmcld_dum, &
4327	rrtm_sw_fsfcld_dum, &
4328	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4329	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4330	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4331	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4332	rrtm_sw_tauaer_dum, &
4333	rrtm_sw_ssaaer_dum, &
4334	rrtm_sw_asmaer_dum, &
4335	rrtm_sw_ecaer_dum, &
4336	rrtm_swuflx(:,k_topo:nzt_rad+1), &
4337	rrtm_swdflx(:,k_topo:nzt_rad+1), &
4338	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
4339	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
4340	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
4341	rrtm_swhrc(:,k_topo+1:nzt_rad+1), &
4342	rrtm_dirdflux(:,k_topo:nzt_rad+1), &
4343	rrtm_difdflux(:,k_topo:nzt_rad+1) )
4344
4345	DEALLOCATE( rrtm_sw_taucld_dum )
4346	DEALLOCATE( rrtm_sw_ssacld_dum )
4347	DEALLOCATE( rrtm_sw_asmcld_dum )
4348	DEALLOCATE( rrtm_sw_fsfcld_dum )
4349	DEALLOCATE( rrtm_sw_tauaer_dum )
4350	DEALLOCATE( rrtm_sw_ssaaer_dum )
4351	DEALLOCATE( rrtm_sw_asmaer_dum )
4352	DEALLOCATE( rrtm_sw_ecaer_dum )
4353
4354	!
4355	!-- Save radiation fluxes for the entire depth of the model domain
4356	DO k = nzb, nzt+1
4357	rad_sw_in(k,:,:) = rrtm_swdflx(0,k)
4358	rad_sw_out(k,:,:) = rrtm_swuflx(0,k)
4359	ENDDO
4360	!-- Save direct and diffuse SW radiation at the surface (required by RTM)
4361	rad_sw_in_dir(:,:) = rrtm_dirdflux(0,k_topo)
4362	rad_sw_in_diff(:,:) = rrtm_difdflux(0,k_topo)
4363
4364	!
4365	!-- Save heating rates (convert from K/d to K/s)
4366	DO k = nzb+1, nzt+1
4367	rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day
4368	rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day
4369	ENDDO
4370	!
4371	!-- Solar radiation is zero during night
4372	ELSE
4373	rad_sw_in = 0.0_wp
4374	rad_sw_out = 0.0_wp
4375	rad_sw_in_dir(:,:) = 0.0_wp
4376	rad_sw_in_diff(:,:) = 0.0_wp
4377	ENDIF
4378	!
4379	!-- RRTMG is called for each (j,i) grid point separately, starting at the
4380	!-- highest topography level. Here no RTM is used since average_radiation is false
4381	ELSE
4382	!
4383	!-- Loop over all grid points
4384	DO i = nxl, nxr
4385	DO j = nys, nyn
4386
4387	!
4388	!-- Prepare profiles of temperature and H2O volume mixing ratio
4389	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4390	rrtm_tlev(0,nzb+1) = surf_lsm_h%pt_surface(m) * exner(nzb)
4391	ENDDO
4392	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4393	rrtm_tlev(0,nzb+1) = surf_usm_h%pt_surface(m) * exner(nzb)
4394	ENDDO
4395
4396
4397	IF ( bulk_cloud_model ) THEN
4398	DO k = nzb+1, nzt+1
4399	rrtm_tlay(0,k) = pt(k,j,i) * exner(k) &
4400	+ lv_d_cp * ql(k,j,i)
4401	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i))
4402	ENDDO
4403	ELSEIF ( cloud_droplets ) THEN
4404	DO k = nzb+1, nzt+1
4405	rrtm_tlay(0,k) = pt(k,j,i) * exner(k) &
4406	+ lv_d_cp * ql(k,j,i)
4407	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i)
4408	ENDDO
4409	ELSE
4410	DO k = nzb+1, nzt+1
4411	rrtm_tlay(0,k) = pt(k,j,i) * exner(k)
4412	ENDDO
4413
4414	IF ( humidity ) THEN
4415	DO k = nzb+1, nzt+1
4416	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i)
4417	ENDDO
4418	ELSE
4419	rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
4420	ENDIF
4421	ENDIF
4422
4423	!
4424	!-- Avoid temperature/humidity jumps at the top of the LES domain by
4425	!-- linear interpolation from nzt+2 to nzt+7
4426	DO k = nzt+2, nzt+7
4427	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
4428	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
4429	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
4430	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4431
4432	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
4433	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
4434	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
4435	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4436
4437	ENDDO
4438
4439	!-- Linear interpolate to zw grid
4440	DO k = nzb+2, nzt+8
4441	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
4442	rrtm_tlay(0,k-1)) &
4443	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4444	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4445	ENDDO
4446
4447
4448	!
4449	!-- Calculate liquid water path and cloud fraction for each column.
4450	!-- Note that LWP is required in g/m2 instead of kg/kg m.
4451	rrtm_cldfr = 0.0_wp
4452	rrtm_reliq = 0.0_wp
4453	rrtm_cliqwp = 0.0_wp
4454	rrtm_icld = 0
4455
4456	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
4457	DO k = nzb+1, nzt+1
4458	rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * &
4459	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
4460	* 100.0_wp / g
4461
4462	IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN
4463	rrtm_cldfr(0,k) = 1.0_wp
4464	IF ( rrtm_icld == 0 ) rrtm_icld = 1
4465
4466	!
4467	!-- Calculate cloud droplet effective radius
4468	IF ( bulk_cloud_model ) THEN
4469	!
4470	!-- Calculete effective droplet radius. In case of using
4471	!-- cloud_scheme = 'morrison' and a non reasonable number
4472	!-- of cloud droplets the inital aerosol number
4473	!-- concentration is considered.
4474	IF ( microphysics_morrison ) THEN
4475	IF ( nc(k,j,i) > 1.0E-20_wp ) THEN
4476	nc_rad = nc(k,j,i)
4477	ELSE
4478	nc_rad = na_init
4479	ENDIF
4480	ELSE
4481	nc_rad = nc_const
4482	ENDIF
4483
4484	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) &
4485	* rho_surface &
4486	/ ( 4.0_wp * pi * nc_rad * rho_l ) &
4487	)**0.33333333333333_wp &
4488	* EXP( LOG( sigma_gc )**2 )
4489
4490	ELSEIF ( cloud_droplets ) THEN
4491	number_of_particles = prt_count(k,j,i)
4492
4493	IF (number_of_particles <= 0) CYCLE
4494	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
4495	s_r2 = 0.0_wp
4496	s_r3 = 0.0_wp
4497
4498	DO n = 1, number_of_particles
4499	IF ( particles(n)%particle_mask ) THEN
4500	s_r2 = s_r2 + particles(n)%radius*2 &
4501	particles(n)%weight_factor
4502	s_r3 = s_r3 + particles(n)%radius*3 &
4503	particles(n)%weight_factor
4504	ENDIF
4505	ENDDO
4506
4507	IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2
4508
4509	ENDIF
4510
4511	!
4512	!-- Limit effective radius
4513	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
4514	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
4515	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
4516	ENDIF
4517	ENDIF
4518	ENDDO
4519	ENDIF
4520
4521	!
4522	!-- Write surface emissivity and surface temperature at current
4523	!-- surface element on RRTMG-shaped array.
4524	!-- Please note, as RRTMG is a single column model, surface attributes
4525	!-- are only obtained from horizontally aligned surfaces (for
4526	!-- simplicity). Taking surface attributes from horizontal and
4527	!-- vertical walls would lead to multiple solutions.
4528	!-- Moreover, for natural- and urban-type surfaces, several surface
4529	!-- classes can exist at a surface element next to each other.
4530	!-- To obtain bulk parameters, apply a weighted average for these
4531	!-- surfaces.
4532	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4533	rrtm_emis = surf_lsm_h%frac(ind_veg_wall,m) * &
4534	surf_lsm_h%emissivity(ind_veg_wall,m) + &
4535	surf_lsm_h%frac(ind_pav_green,m) * &
4536	surf_lsm_h%emissivity(ind_pav_green,m) + &
4537	surf_lsm_h%frac(ind_wat_win,m) * &
4538	surf_lsm_h%emissivity(ind_wat_win,m)
4539	rrtm_tsfc = surf_lsm_h%pt_surface(m) * exner(nzb)
4540	ENDDO
4541	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4542	rrtm_emis = surf_usm_h%frac(ind_veg_wall,m) * &
4543	surf_usm_h%emissivity(ind_veg_wall,m) + &
4544	surf_usm_h%frac(ind_pav_green,m) * &
4545	surf_usm_h%emissivity(ind_pav_green,m) + &
4546	surf_usm_h%frac(ind_wat_win,m) * &
4547	surf_usm_h%emissivity(ind_wat_win,m)
4548	rrtm_tsfc = surf_usm_h%pt_surface(m) * exner(nzb)
4549	ENDDO
4550	!
4551	!-- Obtain topography top index (lower bound of RRTMG)
4552	k_topo = topo_top_ind(j,i,0)
4553
4554	IF ( lw_radiation ) THEN
4555	!
4556	!-- Due to technical reasons, copy optical depth to dummy arguments
4557	!-- which are allocated on the exact size as the rrtmg_lw is called.
4558	!-- As one dimesion is allocated with zero size, compiler complains
4559	!-- that rank of the array does not match that of the
4560	!-- assumed-shaped arguments in the RRTMG library. In order to
4561	!-- avoid this, write to dummy arguments and give pass the entire
4562	!-- dummy array. Seems to be the only existing work-around.
4563	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
4564	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
4565
4566	rrtm_lw_taucld_dum = &
4567	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
4568	rrtm_lw_tauaer_dum = &
4569	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
4570
4571	CALL rrtmg_lw( 1, &
4572	nzt_rad-k_topo, &
4573	rrtm_icld, &
4574	rrtm_idrv, &
4575	rrtm_play(:,k_topo+1:nzt_rad+1), &
4576	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4577	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4578	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4579	rrtm_tsfc, &
4580	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4581	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4582	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4583	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4584	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4585	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4586	rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), &
4587	rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), &
4588	rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), &
4589	rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), &
4590	rrtm_emis, &
4591	rrtm_inflglw, &
4592	rrtm_iceflglw, &
4593	rrtm_liqflglw, &
4594	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4595	rrtm_lw_taucld_dum, &
4596	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4597	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4598	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4599	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4600	rrtm_lw_tauaer_dum, &
4601	rrtm_lwuflx(:,k_topo:nzt_rad+1), &
4602	rrtm_lwdflx(:,k_topo:nzt_rad+1), &
4603	rrtm_lwhr(:,k_topo+1:nzt_rad+1), &
4604	rrtm_lwuflxc(:,k_topo:nzt_rad+1), &
4605	rrtm_lwdflxc(:,k_topo:nzt_rad+1), &
4606	rrtm_lwhrc(:,k_topo+1:nzt_rad+1), &
4607	rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), &
4608	rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) )
4609
4610	DEALLOCATE ( rrtm_lw_taucld_dum )
4611	DEALLOCATE ( rrtm_lw_tauaer_dum )
4612	!
4613	!-- Save fluxes
4614	DO k = k_topo, nzt+1
4615	rad_lw_in(k,j,i) = rrtm_lwdflx(0,k)
4616	rad_lw_out(k,j,i) = rrtm_lwuflx(0,k)
4617	ENDDO
4618
4619	!
4620	!-- Save heating rates (convert from K/d to K/h)
4621	DO k = k_topo+1, nzt+1
4622	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo) * d_hours_day
4623	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo) * d_hours_day
4624	ENDDO
4625
4626	!
4627	!-- Save surface radiative fluxes and change in LW heating rate
4628	!-- onto respective surface elements
4629	!-- Horizontal surfaces
4630	DO m = surf_lsm_h%start_index(j,i), &
4631	surf_lsm_h%end_index(j,i)
4632	surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
4633	surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
4634	surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4635	ENDDO
4636	DO m = surf_usm_h%start_index(j,i), &
4637	surf_usm_h%end_index(j,i)
4638	surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
4639	surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
4640	surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4641	ENDDO
4642	!
4643	!-- Vertical surfaces. Fluxes are obtain at vertical level of the
4644	!-- respective surface element
4645	DO l = 0, 3
4646	DO m = surf_lsm_v(l)%start_index(j,i), &
4647	surf_lsm_v(l)%end_index(j,i)
4648	k = surf_lsm_v(l)%k(m)
4649	surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
4650	surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
4651	surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4652	ENDDO
4653	DO m = surf_usm_v(l)%start_index(j,i), &
4654	surf_usm_v(l)%end_index(j,i)
4655	k = surf_usm_v(l)%k(m)
4656	surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
4657	surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
4658	surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4659	ENDDO
4660	ENDDO
4661
4662	ENDIF
4663
4664	IF ( sw_radiation .AND. sun_up ) THEN
4665	!
4666	!-- Get albedo for direct/diffusive long/shortwave radiation at
4667	!-- current (y,x)-location from surface variables.
4668	!-- Only obtain it from horizontal surfaces, as RRTMG is a single
4669	!-- column model
4670	!-- (Please note, only one loop will entered, controlled by
4671	!-- start-end index.)
4672	DO m = surf_lsm_h%start_index(j,i), &
4673	surf_lsm_h%end_index(j,i)
4674	rrtm_asdir(1) = SUM( surf_lsm_h%frac(:,m) * &
4675	surf_lsm_h%rrtm_asdir(:,m) )
4676	rrtm_asdif(1) = SUM( surf_lsm_h%frac(:,m) * &
4677	surf_lsm_h%rrtm_asdif(:,m) )
4678	rrtm_aldir(1) = SUM( surf_lsm_h%frac(:,m) * &
4679	surf_lsm_h%rrtm_aldir(:,m) )
4680	rrtm_aldif(1) = SUM( surf_lsm_h%frac(:,m) * &
4681	surf_lsm_h%rrtm_aldif(:,m) )
4682	ENDDO
4683	DO m = surf_usm_h%start_index(j,i), &
4684	surf_usm_h%end_index(j,i)
4685	rrtm_asdir(1) = SUM( surf_usm_h%frac(:,m) * &
4686	surf_usm_h%rrtm_asdir(:,m) )
4687	rrtm_asdif(1) = SUM( surf_usm_h%frac(:,m) * &
4688	surf_usm_h%rrtm_asdif(:,m) )
4689	rrtm_aldir(1) = SUM( surf_usm_h%frac(:,m) * &
4690	surf_usm_h%rrtm_aldir(:,m) )
4691	rrtm_aldif(1) = SUM( surf_usm_h%frac(:,m) * &
4692	surf_usm_h%rrtm_aldif(:,m) )
4693	ENDDO
4694	!
4695	!-- Due to technical reasons, copy optical depths and other
4696	!-- to dummy arguments which are allocated on the exact size as the
4697	!-- rrtmg_sw is called.
4698	!-- As one dimesion is allocated with zero size, compiler complains
4699	!-- that rank of the array does not match that of the
4700	!-- assumed-shaped arguments in the RRTMG library. In order to
4701	!-- avoid this, write to dummy arguments and give pass the entire
4702	!-- dummy array. Seems to be the only existing work-around.
4703	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4704	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4705	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4706	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4707	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4708	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4709	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4710	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
4711
4712	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4713	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4714	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4715	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4716	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4717	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4718	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4719	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
4720
4721	CALL rrtmg_sw( 1, &
4722	nzt_rad-k_topo, &
4723	rrtm_icld, &
4724	rrtm_iaer, &
4725	rrtm_play(:,k_topo+1:nzt_rad+1), &
4726	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4727	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4728	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4729	rrtm_tsfc, &
4730	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4731	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4732	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4733	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4734	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4735	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4736	rrtm_asdir, &
4737	rrtm_asdif, &
4738	rrtm_aldir, &
4739	rrtm_aldif, &
4740	zenith, &
4741	0.0_wp, &
4742	day_of_year, &
4743	solar_constant, &
4744	rrtm_inflgsw, &
4745	rrtm_iceflgsw, &
4746	rrtm_liqflgsw, &
4747	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4748	rrtm_sw_taucld_dum, &
4749	rrtm_sw_ssacld_dum, &
4750	rrtm_sw_asmcld_dum, &
4751	rrtm_sw_fsfcld_dum, &
4752	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4753	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4754	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4755	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4756	rrtm_sw_tauaer_dum, &
4757	rrtm_sw_ssaaer_dum, &
4758	rrtm_sw_asmaer_dum, &
4759	rrtm_sw_ecaer_dum, &
4760	rrtm_swuflx(:,k_topo:nzt_rad+1), &
4761	rrtm_swdflx(:,k_topo:nzt_rad+1), &
4762	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
4763	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
4764	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
4765	rrtm_swhrc(:,k_topo+1:nzt_rad+1), &
4766	rrtm_dirdflux(:,k_topo:nzt_rad+1), &
4767	rrtm_difdflux(:,k_topo:nzt_rad+1) )
4768
4769	DEALLOCATE( rrtm_sw_taucld_dum )
4770	DEALLOCATE( rrtm_sw_ssacld_dum )
4771	DEALLOCATE( rrtm_sw_asmcld_dum )
4772	DEALLOCATE( rrtm_sw_fsfcld_dum )
4773	DEALLOCATE( rrtm_sw_tauaer_dum )
4774	DEALLOCATE( rrtm_sw_ssaaer_dum )
4775	DEALLOCATE( rrtm_sw_asmaer_dum )
4776	DEALLOCATE( rrtm_sw_ecaer_dum )
4777	!
4778	!-- Save fluxes
4779	DO k = nzb, nzt+1
4780	rad_sw_in(k,j,i) = rrtm_swdflx(0,k)
4781	rad_sw_out(k,j,i) = rrtm_swuflx(0,k)
4782	ENDDO
4783	!
4784	!-- Save heating rates (convert from K/d to K/s)
4785	DO k = nzb+1, nzt+1
4786	rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day
4787	rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day
4788	ENDDO
4789
4790	!
4791	!-- Save surface radiative fluxes onto respective surface elements
4792	!-- Horizontal surfaces
4793	DO m = surf_lsm_h%start_index(j,i), &
4794	surf_lsm_h%end_index(j,i)
4795	surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
4796	surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
4797	ENDDO
4798	DO m = surf_usm_h%start_index(j,i), &
4799	surf_usm_h%end_index(j,i)
4800	surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
4801	surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
4802	ENDDO
4803	!
4804	!-- Vertical surfaces. Fluxes are obtain at respective vertical
4805	!-- level of the surface element
4806	DO l = 0, 3
4807	DO m = surf_lsm_v(l)%start_index(j,i), &
4808	surf_lsm_v(l)%end_index(j,i)
4809	k = surf_lsm_v(l)%k(m)
4810	surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
4811	surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4812	ENDDO
4813	DO m = surf_usm_v(l)%start_index(j,i), &
4814	surf_usm_v(l)%end_index(j,i)
4815	k = surf_usm_v(l)%k(m)
4816	surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
4817	surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4818	ENDDO
4819	ENDDO
4820	!
4821	!-- Solar radiation is zero during night
4822	ELSE
4823	rad_sw_in = 0.0_wp
4824	rad_sw_out = 0.0_wp
4825	!-- !!!!!!!! ATTENSION !!!!!!!!!!!!!!!
4826	!-- Surface radiative fluxes should be also set to zero here
4827	!-- Save surface radiative fluxes onto respective surface elements
4828	!-- Horizontal surfaces
4829	DO m = surf_lsm_h%start_index(j,i), &
4830	surf_lsm_h%end_index(j,i)
4831	surf_lsm_h%rad_sw_in(m) = 0.0_wp
4832	surf_lsm_h%rad_sw_out(m) = 0.0_wp
4833	ENDDO
4834	DO m = surf_usm_h%start_index(j,i), &
4835	surf_usm_h%end_index(j,i)
4836	surf_usm_h%rad_sw_in(m) = 0.0_wp
4837	surf_usm_h%rad_sw_out(m) = 0.0_wp
4838	ENDDO
4839	!
4840	!-- Vertical surfaces. Fluxes are obtain at respective vertical
4841	!-- level of the surface element
4842	DO l = 0, 3
4843	DO m = surf_lsm_v(l)%start_index(j,i), &
4844	surf_lsm_v(l)%end_index(j,i)
4845	k = surf_lsm_v(l)%k(m)
4846	surf_lsm_v(l)%rad_sw_in(m) = 0.0_wp
4847	surf_lsm_v(l)%rad_sw_out(m) = 0.0_wp
4848	ENDDO
4849	DO m = surf_usm_v(l)%start_index(j,i), &
4850	surf_usm_v(l)%end_index(j,i)
4851	k = surf_usm_v(l)%k(m)
4852	surf_usm_v(l)%rad_sw_in(m) = 0.0_wp
4853	surf_usm_v(l)%rad_sw_out(m) = 0.0_wp
4854	ENDDO
4855	ENDDO
4856	ENDIF
4857
4858	ENDDO
4859	ENDDO
4860
4861	ENDIF
4862	!
4863	!-- Finally, calculate surface net radiation for surface elements.
4864	IF ( .NOT. radiation_interactions ) THEN
4865	!-- First, for horizontal surfaces
4866	DO m = 1, surf_lsm_h%ns
4867	surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) &
4868	- surf_lsm_h%rad_sw_out(m) &
4869	+ surf_lsm_h%rad_lw_in(m) &
4870	- surf_lsm_h%rad_lw_out(m)
4871	ENDDO
4872	DO m = 1, surf_usm_h%ns
4873	surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) &
4874	- surf_usm_h%rad_sw_out(m) &
4875	+ surf_usm_h%rad_lw_in(m) &
4876	- surf_usm_h%rad_lw_out(m)
4877	ENDDO
4878	!
4879	!-- Vertical surfaces.
4880	!-- Todo: weight with azimuth and zenith angle according to their orientation!
4881	DO l = 0, 3
4882	DO m = 1, surf_lsm_v(l)%ns
4883	surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) &
4884	- surf_lsm_v(l)%rad_sw_out(m) &
4885	+ surf_lsm_v(l)%rad_lw_in(m) &
4886	- surf_lsm_v(l)%rad_lw_out(m)
4887	ENDDO
4888	DO m = 1, surf_usm_v(l)%ns
4889	surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) &
4890	- surf_usm_v(l)%rad_sw_out(m) &
4891	+ surf_usm_v(l)%rad_lw_in(m) &
4892	- surf_usm_v(l)%rad_lw_out(m)
4893	ENDDO
4894	ENDDO
4895	ENDIF
4896
4897
4898	CALL exchange_horiz( rad_lw_in, nbgp )
4899	CALL exchange_horiz( rad_lw_out, nbgp )
4900	CALL exchange_horiz( rad_lw_hr, nbgp )
4901	CALL exchange_horiz( rad_lw_cs_hr, nbgp )
4902
4903	CALL exchange_horiz( rad_sw_in, nbgp )
4904	CALL exchange_horiz( rad_sw_out, nbgp )
4905	CALL exchange_horiz( rad_sw_hr, nbgp )
4906	CALL exchange_horiz( rad_sw_cs_hr, nbgp )
4907
4908	#endif
4909
4910	END SUBROUTINE radiation_rrtmg
4911
4912
4913	!------------------------------------------------------------------------------!
4914	! Description:
4915	! ------------
4916	!> Calculate the cosine of the zenith angle (variable is called zenith)
4917	!------------------------------------------------------------------------------!
4918	SUBROUTINE calc_zenith( day_of_year, second_of_day )
4919
4920	USE palm_date_time_mod, &
4921	ONLY: seconds_per_day
4922
4923	IMPLICIT NONE
4924
4925	INTEGER(iwp), INTENT(IN) :: day_of_year !< day of the year
4926
4927	REAL(wp) :: declination !< solar declination angle
4928	REAL(wp) :: hour_angle !< solar hour angle
4929	REAL(wp), INTENT(IN) :: second_of_day !< current time of the day in UTC
4930
4931	!
4932	!-- Calculate solar declination and hour angle
4933	declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) )
4934	hour_angle = 2.0_wp * pi * ( second_of_day / seconds_per_day ) + lon - pi
4935
4936	!
4937	!-- Calculate cosine of solar zenith angle
4938	cos_zenith = SIN(lat) * SIN(declination) + COS(lat) * COS(declination) &
4939	* COS(hour_angle)
4940	cos_zenith = MAX(0.0_wp,cos_zenith)
4941
4942	!
4943	!-- Calculate solar directional vector
4944	IF ( sun_direction ) THEN
4945
4946	!
4947	!-- Direction in longitudes equals to sin(solar_azimuth) * sin(zenith)
4948	sun_dir_lon = -SIN(hour_angle) * COS(declination)
4949
4950	!
4951	!-- Direction in latitues equals to cos(solar_azimuth) * sin(zenith)
4952	sun_dir_lat = SIN(declination) * COS(lat) - COS(hour_angle) &
4953	* COS(declination) * SIN(lat)
4954	ENDIF
4955
4956	!
4957	!-- Check if the sun is up (otheriwse shortwave calculations can be skipped)
4958	IF ( cos_zenith > 0.0_wp ) THEN
4959	sun_up = .TRUE.
4960	ELSE
4961	sun_up = .FALSE.
4962	END IF
4963
4964	END SUBROUTINE calc_zenith
4965
4966	#if defined ( __rrtmg ) && defined ( __netcdf )
4967	!------------------------------------------------------------------------------!
4968	! Description:
4969	! ------------
4970	!> Calculates surface albedo components based on Briegleb (1992) and
4971	!> Briegleb et al. (1986)
4972	!------------------------------------------------------------------------------!
4973	SUBROUTINE calc_albedo( surf )
4974
4975	IMPLICIT NONE
4976
4977	INTEGER(iwp) :: ind_type !< running index surface tiles
4978	INTEGER(iwp) :: m !< running index surface elements
4979
4980	TYPE(surf_type) :: surf !< treated surfaces
4981
4982	IF ( sun_up .AND. .NOT. average_radiation ) THEN
4983
4984	DO m = 1, surf%ns
4985	!
4986	!-- Loop over surface elements
4987	DO ind_type = 0, SIZE( surf%albedo_type, 1 ) - 1
4988
4989	!
4990	!-- Ocean
4991	IF ( surf%albedo_type(ind_type,m) == 1 ) THEN
4992	surf%rrtm_aldir(ind_type,m) = 0.026_wp / &
4993	( cos_zenith**1.7_wp + 0.065_wp )&
4994	+ 0.15_wp * ( cos_zenith - 0.1_wp ) &
4995	* ( cos_zenith - 0.5_wp ) &
4996	* ( cos_zenith - 1.0_wp )
4997	surf%rrtm_asdir(ind_type,m) = surf%rrtm_aldir(ind_type,m)
4998	!
4999	!-- Snow
5000	ELSEIF ( surf%albedo_type(ind_type,m) == 16 ) THEN
5001	IF ( cos_zenith < 0.5_wp ) THEN
5002	surf%rrtm_aldir(ind_type,m) = &
5003	0.5_wp * ( 1.0_wp - surf%aldif(ind_type,m) ) &
5004	* ( ( 3.0_wp / ( 1.0_wp + 4.0_wp &
5005	* cos_zenith ) ) - 1.0_wp )
5006	surf%rrtm_asdir(ind_type,m) = &
5007	0.5_wp * ( 1.0_wp - surf%asdif(ind_type,m) ) &
5008	* ( ( 3.0_wp / ( 1.0_wp + 4.0_wp &
5009	* cos_zenith ) ) - 1.0_wp )
5010
5011	surf%rrtm_aldir(ind_type,m) = &
5012	MIN(0.98_wp, surf%rrtm_aldir(ind_type,m))
5013	surf%rrtm_asdir(ind_type,m) = &
5014	MIN(0.98_wp, surf%rrtm_asdir(ind_type,m))
5015	ELSE
5016	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
5017	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
5018	ENDIF
5019	!
5020	!-- Sea ice
5021	ELSEIF ( surf%albedo_type(ind_type,m) == 15 ) THEN
5022	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
5023	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
5024
5025	!
5026	!-- Asphalt
5027	ELSEIF ( surf%albedo_type(ind_type,m) == 17 ) THEN
5028	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
5029	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
5030
5031
5032	!
5033	!-- Bare soil
5034	ELSEIF ( surf%albedo_type(ind_type,m) == 18 ) THEN
5035	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
5036	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
5037
5038	!
5039	!-- Land surfaces
5040	ELSE
5041	SELECT CASE ( surf%albedo_type(ind_type,m) )
5042
5043	!
5044	!-- Surface types with strong zenith dependence
5045	CASE ( 1, 2, 3, 4, 11, 12, 13 )
5046	surf%rrtm_aldir(ind_type,m) = &
5047	surf%aldif(ind_type,m) * 1.4_wp / &
5048	( 1.0_wp + 0.8_wp * cos_zenith )
5049	surf%rrtm_asdir(ind_type,m) = &
5050	surf%asdif(ind_type,m) * 1.4_wp / &
5051	( 1.0_wp + 0.8_wp * cos_zenith )
5052	!
5053	!-- Surface types with weak zenith dependence
5054	CASE ( 5, 6, 7, 8, 9, 10, 14 )
5055	surf%rrtm_aldir(ind_type,m) = &
5056	surf%aldif(ind_type,m) * 1.1_wp / &
5057	( 1.0_wp + 0.2_wp * cos_zenith )
5058	surf%rrtm_asdir(ind_type,m) = &
5059	surf%asdif(ind_type,m) * 1.1_wp / &
5060	( 1.0_wp + 0.2_wp * cos_zenith )
5061
5062	CASE DEFAULT
5063
5064	END SELECT
5065	ENDIF
5066	!
5067	!-- Diffusive albedo is taken from Table 2
5068	surf%rrtm_aldif(ind_type,m) = surf%aldif(ind_type,m)
5069	surf%rrtm_asdif(ind_type,m) = surf%asdif(ind_type,m)
5070	ENDDO
5071	ENDDO
5072	!
5073	!-- Set albedo in case of average radiation
5074	ELSEIF ( sun_up .AND. average_radiation ) THEN
5075	surf%rrtm_asdir = albedo_urb
5076	surf%rrtm_asdif = albedo_urb
5077	surf%rrtm_aldir = albedo_urb
5078	surf%rrtm_aldif = albedo_urb
5079	!
5080	!-- Darkness
5081	ELSE
5082	surf%rrtm_aldir = 0.0_wp
5083	surf%rrtm_asdir = 0.0_wp
5084	surf%rrtm_aldif = 0.0_wp
5085	surf%rrtm_asdif = 0.0_wp
5086	ENDIF
5087
5088	END SUBROUTINE calc_albedo
5089
5090	!------------------------------------------------------------------------------!
5091	! Description:
5092	! ------------
5093	!> Read sounding data (pressure and temperature) from RADIATION_DATA.
5094	!------------------------------------------------------------------------------!
5095	SUBROUTINE read_sounding_data
5096
5097	IMPLICIT NONE
5098
5099	INTEGER(iwp) :: id, & !< NetCDF id of input file
5100	id_dim_zrad, & !< pressure level id in the NetCDF file
5101	id_var, & !< NetCDF variable id
5102	k, & !< loop index
5103	nz_snd, & !< number of vertical levels in the sounding data
5104	nz_snd_start, & !< start vertical index for sounding data to be used
5105	nz_snd_end !< end vertical index for souding data to be used
5106
5107	REAL(wp) :: t_surface !< actual surface temperature
5108
5109	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding)
5110	t_snd_tmp !< temporary temperature profile (sounding)
5111
5112	!
5113	!-- In case of updates, deallocate arrays first (sufficient to check one
5114	!-- array as the others are automatically allocated). This is required
5115	!-- because nzt_rad might change during the update
5116	IF ( ALLOCATED ( hyp_snd ) ) THEN
5117	DEALLOCATE( hyp_snd )
5118	DEALLOCATE( t_snd )
5119	DEALLOCATE ( rrtm_play )
5120	DEALLOCATE ( rrtm_plev )
5121	DEALLOCATE ( rrtm_tlay )
5122	DEALLOCATE ( rrtm_tlev )
5123
5124	DEALLOCATE ( rrtm_cicewp )
5125	DEALLOCATE ( rrtm_cldfr )
5126	DEALLOCATE ( rrtm_cliqwp )
5127	DEALLOCATE ( rrtm_reice )
5128	DEALLOCATE ( rrtm_reliq )
5129	DEALLOCATE ( rrtm_lw_taucld )
5130	DEALLOCATE ( rrtm_lw_tauaer )
5131
5132	DEALLOCATE ( rrtm_lwdflx )
5133	DEALLOCATE ( rrtm_lwdflxc )
5134	DEALLOCATE ( rrtm_lwuflx )
5135	DEALLOCATE ( rrtm_lwuflxc )
5136	DEALLOCATE ( rrtm_lwuflx_dt )
5137	DEALLOCATE ( rrtm_lwuflxc_dt )
5138	DEALLOCATE ( rrtm_lwhr )
5139	DEALLOCATE ( rrtm_lwhrc )
5140
5141	DEALLOCATE ( rrtm_sw_taucld )
5142	DEALLOCATE ( rrtm_sw_ssacld )
5143	DEALLOCATE ( rrtm_sw_asmcld )
5144	DEALLOCATE ( rrtm_sw_fsfcld )
5145	DEALLOCATE ( rrtm_sw_tauaer )
5146	DEALLOCATE ( rrtm_sw_ssaaer )
5147	DEALLOCATE ( rrtm_sw_asmaer )
5148	DEALLOCATE ( rrtm_sw_ecaer )
5149
5150	DEALLOCATE ( rrtm_swdflx )
5151	DEALLOCATE ( rrtm_swdflxc )
5152	DEALLOCATE ( rrtm_swuflx )
5153	DEALLOCATE ( rrtm_swuflxc )
5154	DEALLOCATE ( rrtm_swhr )
5155	DEALLOCATE ( rrtm_swhrc )
5156	DEALLOCATE ( rrtm_dirdflux )
5157	DEALLOCATE ( rrtm_difdflux )
5158
5159	ENDIF
5160
5161	!
5162	!-- Open file for reading
5163	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
5164	CALL netcdf_handle_error_rad( 'read_sounding_data', 549 )
5165
5166	!
5167	!-- Inquire dimension of z axis and save in nz_snd
5168	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad )
5169	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd )
5170	CALL netcdf_handle_error_rad( 'read_sounding_data', 551 )
5171
5172	!
5173	! !-- Allocate temporary array for storing pressure data
5174	ALLOCATE( hyp_snd_tmp(1:nz_snd) )
5175	hyp_snd_tmp = 0.0_wp
5176
5177
5178	!-- Read pressure from file
5179	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
5180	nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/), &
5181	count = (/nz_snd/) )
5182	CALL netcdf_handle_error_rad( 'read_sounding_data', 552 )
5183
5184	!
5185	!-- Allocate temporary array for storing temperature data
5186	ALLOCATE( t_snd_tmp(1:nz_snd) )
5187	t_snd_tmp = 0.0_wp
5188
5189	!
5190	!-- Read temperature from file
5191	nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var )
5192	nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/), &
5193	count = (/nz_snd/) )
5194	CALL netcdf_handle_error_rad( 'read_sounding_data', 553 )
5195
5196	!
5197	!-- Calculate start of sounding data
5198	nz_snd_start = nz_snd + 1
5199	nz_snd_end = nz_snd + 1
5200
5201	!
5202	!-- Start filling vertical dimension at 10hPa above the model domain (hyp is
5203	!-- in Pa, hyp_snd in hPa).
5204	DO k = 1, nz_snd
5205	IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp ) THEN
5206	nz_snd_start = k
5207	EXIT
5208	END IF
5209	END DO
5210
5211	IF ( nz_snd_start <= nz_snd ) THEN
5212	nz_snd_end = nz_snd
5213	END IF
5214
5215
5216	!
5217	!-- Calculate of total grid points for RRTMG calculations
5218	nzt_rad = nzt + nz_snd_end - nz_snd_start + 1
5219
5220	!
5221	!-- Save data above LES domain in hyp_snd, t_snd
5222	ALLOCATE( hyp_snd(nzb+1:nzt_rad) )
5223	ALLOCATE( t_snd(nzb+1:nzt_rad) )
5224	hyp_snd = 0.0_wp
5225	t_snd = 0.0_wp
5226
5227	hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end)
5228	t_snd(nzt+2:nzt_rad) = t_snd_tmp(nz_snd_start+1:nz_snd_end)
5229
5230	nc_stat = NF90_CLOSE( id )
5231
5232	!
5233	!-- Calculate pressure levels on zu and zw grid. Sounding data is added at
5234	!-- top of the LES domain. This routine does not consider horizontal or
5235	!-- vertical variability of pressure and temperature
5236	ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1) )
5237	ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2) )
5238
5239	t_surface = pt_surface * exner(nzb)
5240	DO k = nzb+1, nzt+1
5241	rrtm_play(0,k) = hyp(k) * 0.01_wp
5242	rrtm_plev(0,k) = barometric_formula(zw(k-1), &
5243	pt_surface * exner(nzb), &
5244	surface_pressure )
5245	ENDDO
5246
5247	DO k = nzt+2, nzt_rad
5248	rrtm_play(0,k) = hyp_snd(k)
5249	rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) )
5250	ENDDO
5251	rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad), &
5252	1.5 * hyp_snd(nzt_rad) &
5253	- 0.5 * hyp_snd(nzt_rad-1) )
5254	rrtm_plev(0,nzt_rad+2) = MIN( 1.0E-4_wp, &
5255	0.25_wp * rrtm_plev(0,nzt_rad+1) )
5256
5257	rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1)
5258
5259	!
5260	!-- Calculate temperature/humidity levels at top of the LES domain.
5261	!-- Currently, the temperature is taken from sounding data (might lead to a
5262	!-- temperature jump at interface. To do: Humidity is currently not
5263	!-- calculated above the LES domain.
5264	ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1) )
5265	ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2) )
5266
5267	DO k = nzt+8, nzt_rad
5268	rrtm_tlay(0,k) = t_snd(k)
5269	ENDDO
5270	rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad) &
5271	- rrtm_tlay(0,nzt_rad-1)
5272	DO k = nzt+9, nzt_rad+1
5273	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) &
5274	- rrtm_tlay(0,k-1)) &
5275	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
5276	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
5277	ENDDO
5278
5279	rrtm_tlev(0,nzt_rad+2) = 2.0_wp * rrtm_tlay(0,nzt_rad+1) &
5280	- rrtm_tlev(0,nzt_rad)
5281	!
5282	!-- Allocate remaining RRTMG arrays
5283	ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) )
5284	ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) )
5285	ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) )
5286	ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) )
5287	ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) )
5288	ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) )
5289	ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) )
5290	ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5291	ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5292	ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5293	ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5294	ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
5295	ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
5296	ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
5297	ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) )
5298
5299	!
5300	!-- The ice phase is currently not considered in PALM
5301	rrtm_cicewp = 0.0_wp
5302	rrtm_reice = 0.0_wp
5303
5304	!
5305	!-- Set other parameters (move to NAMELIST parameters in the future)
5306	rrtm_lw_tauaer = 0.0_wp
5307	rrtm_lw_taucld = 0.0_wp
5308	rrtm_sw_taucld = 0.0_wp
5309	rrtm_sw_ssacld = 0.0_wp
5310	rrtm_sw_asmcld = 0.0_wp
5311	rrtm_sw_fsfcld = 0.0_wp
5312	rrtm_sw_tauaer = 0.0_wp
5313	rrtm_sw_ssaaer = 0.0_wp
5314	rrtm_sw_asmaer = 0.0_wp
5315	rrtm_sw_ecaer = 0.0_wp
5316
5317
5318	ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1) )
5319	ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1) )
5320	ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1) )
5321	ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) )
5322	ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) )
5323	ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) )
5324	ALLOCATE ( rrtm_dirdflux(0:0,nzb:nzt_rad+1) )
5325	ALLOCATE ( rrtm_difdflux(0:0,nzb:nzt_rad+1) )
5326
5327	rrtm_swdflx = 0.0_wp
5328	rrtm_swuflx = 0.0_wp
5329	rrtm_swhr = 0.0_wp
5330	rrtm_swuflxc = 0.0_wp
5331	rrtm_swdflxc = 0.0_wp
5332	rrtm_swhrc = 0.0_wp
5333	rrtm_dirdflux = 0.0_wp
5334	rrtm_difdflux = 0.0_wp
5335
5336	ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1) )
5337	ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1) )
5338	ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1) )
5339	ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) )
5340	ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) )
5341	ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) )
5342
5343	rrtm_lwdflx = 0.0_wp
5344	rrtm_lwuflx = 0.0_wp
5345	rrtm_lwhr = 0.0_wp
5346	rrtm_lwuflxc = 0.0_wp
5347	rrtm_lwdflxc = 0.0_wp
5348	rrtm_lwhrc = 0.0_wp
5349
5350	ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) )
5351	ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) )
5352
5353	rrtm_lwuflx_dt = 0.0_wp
5354	rrtm_lwuflxc_dt = 0.0_wp
5355
5356	END SUBROUTINE read_sounding_data
5357
5358
5359	!------------------------------------------------------------------------------!
5360	! Description:
5361	! ------------
5362	!> Read trace gas data from file and convert into trace gas paths / volume
5363	!> mixing ratios. If a user-defined input file is provided it needs to follow
5364	!> the convections used in RRTMG (see respective netCDF files shipped with
5365	!> RRTMG)
5366	!------------------------------------------------------------------------------!
5367	SUBROUTINE read_trace_gas_data
5368
5369	USE rrsw_ncpar
5370
5371	IMPLICIT NONE
5372
5373	INTEGER(iwp), PARAMETER :: num_trace_gases = 10 !< number of trace gases (absorbers)
5374
5375	CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER :: & !< trace gas names
5376	trace_names = (/'O3 ', 'CO2 ', 'CH4 ', 'N2O ', 'O2 ', &
5377	'CFC11', 'CFC12', 'CFC22', 'CCL4 ', 'H2O '/)
5378
5379	INTEGER(iwp) :: id, & !< NetCDF id
5380	k, & !< loop index
5381	m, & !< loop index
5382	n, & !< loop index
5383	nabs, & !< number of absorbers
5384	np, & !< number of pressure levels
5385	id_abs, & !< NetCDF id of the respective absorber
5386	id_dim, & !< NetCDF id of asborber's dimension
5387	id_var !< NetCDf id ot the absorber
5388
5389	REAL(wp) :: p_mls_l, & !< pressure lower limit for interpolation
5390	p_mls_u, & !< pressure upper limit for interpolation
5391	p_wgt_l, & !< pressure weight lower limit for interpolation
5392	p_wgt_u, & !< pressure weight upper limit for interpolation
5393	p_mls_m !< mean pressure between upper and lower limits
5394
5395
5396	REAL(wp), DIMENSION(:), ALLOCATABLE :: p_mls, & !< pressure levels for the absorbers
5397	rrtm_play_tmp, & !< temporary array for pressure zu-levels
5398	rrtm_plev_tmp, & !< temporary array for pressure zw-levels
5399	trace_path_tmp !< temporary array for storing trace gas path data
5400
5401	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: trace_mls, & !< array for storing the absorber amounts
5402	trace_mls_path, & !< array for storing trace gas path data
5403	trace_mls_tmp !< temporary array for storing trace gas data
5404
5405
5406	!
5407	!-- In case of updates, deallocate arrays first (sufficient to check one
5408	!-- array as the others are automatically allocated)
5409	IF ( ALLOCATED ( rrtm_o3vmr ) ) THEN
5410	DEALLOCATE ( rrtm_o3vmr )
5411	DEALLOCATE ( rrtm_co2vmr )
5412	DEALLOCATE ( rrtm_ch4vmr )
5413	DEALLOCATE ( rrtm_n2ovmr )
5414	DEALLOCATE ( rrtm_o2vmr )
5415	DEALLOCATE ( rrtm_cfc11vmr )
5416	DEALLOCATE ( rrtm_cfc12vmr )
5417	DEALLOCATE ( rrtm_cfc22vmr )
5418	DEALLOCATE ( rrtm_ccl4vmr )
5419	DEALLOCATE ( rrtm_h2ovmr )
5420	ENDIF
5421
5422	!
5423	!-- Allocate trace gas profiles
5424	ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1) )
5425	ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) )
5426	ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) )
5427	ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) )
5428	ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1) )
5429	ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) )
5430	ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) )
5431	ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) )
5432	ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1) )
5433	ALLOCATE ( rrtm_h2ovmr(0:0,1:nzt_rad+1) )
5434
5435	!
5436	!-- Open file for reading
5437	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
5438	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 )
5439	!
5440	!-- Inquire dimension ids and dimensions
5441	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim )
5442	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5443	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np)
5444	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5445
5446	nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim )
5447	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5448	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs )
5449	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5450
5451
5452	!
5453	!-- Allocate pressure, and trace gas arrays
5454	ALLOCATE( p_mls(1:np) )
5455	ALLOCATE( trace_mls(1:num_trace_gases,1:np) )
5456	ALLOCATE( trace_mls_tmp(1:nabs,1:np) )
5457
5458
5459	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
5460	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5461	nc_stat = NF90_GET_VAR( id, id_var, p_mls )
5462	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5463
5464	nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var )
5465	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5466	nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp )
5467	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5468
5469
5470	!
5471	!-- Write absorber amounts (mls) to trace_mls
5472	DO n = 1, num_trace_gases
5473	CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs )
5474
5475	trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np)
5476
5477	!
5478	!-- Replace missing values by zero
5479	WHERE ( trace_mls(n,:) > 2.0_wp )
5480	trace_mls(n,:) = 0.0_wp
5481	END WHERE
5482	END DO
5483
5484	DEALLOCATE ( trace_mls_tmp )
5485
5486	nc_stat = NF90_CLOSE( id )
5487	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 )
5488
5489	!
5490	!-- Add extra pressure level for calculations of the trace gas paths
5491	ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) )
5492	ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) )
5493
5494	rrtm_play_tmp(1:nzt_rad) = rrtm_play(0,1:nzt_rad)
5495	rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1)
5496	rrtm_play_tmp(nzt_rad+1) = rrtm_plev(0,nzt_rad+1) * 0.5_wp
5497	rrtm_plev_tmp(nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp &
5498	* rrtm_plev(0,nzt_rad+1) )
5499
5500	!
5501	!-- Calculate trace gas path (zero at surface) with interpolation to the
5502	!-- sounding levels
5503	ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) )
5504
5505	trace_mls_path(nzb+1,:) = 0.0_wp
5506
5507	DO k = nzb+2, nzt_rad+2
5508	DO m = 1, num_trace_gases
5509	trace_mls_path(k,m) = trace_mls_path(k-1,m)
5510
5511	!
5512	!-- When the pressure level is higher than the trace gas pressure
5513	!-- level, assume that
5514	IF ( rrtm_plev_tmp(k-1) > p_mls(1) ) THEN
5515
5516	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1) &
5517	* ( rrtm_plev_tmp(k-1) &
5518	- MAX( p_mls(1), rrtm_plev_tmp(k) ) &
5519	) / g
5520	ENDIF
5521
5522	!
5523	!-- Integrate for each sounding level from the contributing p_mls
5524	!-- levels
5525	DO n = 2, np
5526	!
5527	!-- Limit p_mls so that it is within the model level
5528	p_mls_u = MIN( rrtm_plev_tmp(k-1), &
5529	MAX( rrtm_plev_tmp(k), p_mls(n) ) )
5530	p_mls_l = MIN( rrtm_plev_tmp(k-1), &
5531	MAX( rrtm_plev_tmp(k), p_mls(n-1) ) )
5532
5533	IF ( p_mls_l > p_mls_u ) THEN
5534
5535	!
5536	!-- Calculate weights for interpolation
5537	p_mls_m = 0.5_wp * (p_mls_l + p_mls_u)
5538	p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n))
5539	p_wgt_l = (p_mls_m - p_mls(n)) / (p_mls(n-1) - p_mls(n))
5540
5541	!
5542	!-- Add level to trace gas path
5543	trace_mls_path(k,m) = trace_mls_path(k,m) &
5544	+ ( p_wgt_u * trace_mls(m,n) &
5545	+ p_wgt_l * trace_mls(m,n-1) ) &
5546	* (p_mls_l - p_mls_u) / g
5547	ENDIF
5548	ENDDO
5549
5550	IF ( rrtm_plev_tmp(k) < p_mls(np) ) THEN
5551	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np) &
5552	* ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) &
5553	- rrtm_plev_tmp(k) &
5554	) / g
5555	ENDIF
5556	ENDDO
5557	ENDDO
5558
5559
5560	!
5561	!-- Prepare trace gas path profiles
5562	ALLOCATE ( trace_path_tmp(1:nzt_rad+1) )
5563
5564	DO m = 1, num_trace_gases
5565
5566	trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m) &
5567	- trace_mls_path(1:nzt_rad+1,m) ) * g &
5568	/ ( rrtm_plev_tmp(1:nzt_rad+1) &
5569	- rrtm_plev_tmp(2:nzt_rad+2) )
5570
5571	!
5572	!-- Save trace gas paths to the respective arrays
5573	SELECT CASE ( TRIM( trace_names(m) ) )
5574
5575	CASE ( 'O3' )
5576
5577	rrtm_o3vmr(0,:) = trace_path_tmp(:)
5578
5579	CASE ( 'CO2' )
5580
5581	rrtm_co2vmr(0,:) = trace_path_tmp(:)
5582
5583	CASE ( 'CH4' )
5584
5585	rrtm_ch4vmr(0,:) = trace_path_tmp(:)
5586
5587	CASE ( 'N2O' )
5588
5589	rrtm_n2ovmr(0,:) = trace_path_tmp(:)
5590
5591	CASE ( 'O2' )
5592
5593	rrtm_o2vmr(0,:) = trace_path_tmp(:)
5594
5595	CASE ( 'CFC11' )
5596
5597	rrtm_cfc11vmr(0,:) = trace_path_tmp(:)
5598
5599	CASE ( 'CFC12' )
5600
5601	rrtm_cfc12vmr(0,:) = trace_path_tmp(:)
5602
5603	CASE ( 'CFC22' )
5604
5605	rrtm_cfc22vmr(0,:) = trace_path_tmp(:)
5606
5607	CASE ( 'CCL4' )
5608
5609	rrtm_ccl4vmr(0,:) = trace_path_tmp(:)
5610
5611	CASE ( 'H2O' )
5612
5613	rrtm_h2ovmr(0,:) = trace_path_tmp(:)
5614
5615	CASE DEFAULT
5616
5617	END SELECT
5618
5619	ENDDO
5620
5621	DEALLOCATE ( trace_path_tmp )
5622	DEALLOCATE ( trace_mls_path )
5623	DEALLOCATE ( rrtm_play_tmp )
5624	DEALLOCATE ( rrtm_plev_tmp )
5625	DEALLOCATE ( trace_mls )
5626	DEALLOCATE ( p_mls )
5627
5628	END SUBROUTINE read_trace_gas_data
5629
5630
5631	SUBROUTINE netcdf_handle_error_rad( routine_name, errno )
5632
5633	USE control_parameters, &
5634	ONLY: message_string
5635
5636	USE NETCDF
5637
5638	USE pegrid
5639
5640	IMPLICIT NONE
5641
5642	CHARACTER(LEN=6) :: message_identifier
5643	CHARACTER(LEN=*) :: routine_name
5644
5645	INTEGER(iwp) :: errno
5646
5647	IF ( nc_stat /= NF90_NOERR ) THEN
5648
5649	WRITE( message_identifier, '(''NC'',I4.4)' ) errno
5650	message_string = TRIM( NF90_STRERROR( nc_stat ) )
5651
5652	CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )
5653
5654	ENDIF
5655
5656	END SUBROUTINE netcdf_handle_error_rad
5657	#endif
5658
5659
5660	!------------------------------------------------------------------------------!
5661	! Description:
5662	! ------------
5663	!> Calculate temperature tendency due to radiative cooling/heating.
5664	!> Cache-optimized version.
5665	!------------------------------------------------------------------------------!
5666	#if defined( __rrtmg )
5667	SUBROUTINE radiation_tendency_ij ( i, j, tend )
5668
5669	IMPLICIT NONE
5670
5671	INTEGER(iwp) :: i, j, k !< loop indices
5672
5673	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5674
5675	IF ( radiation_scheme == 'rrtmg' ) THEN
5676	!
5677	!-- Calculate tendency based on heating rate
5678	DO k = nzb+1, nzt+1
5679	tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i)) &
5680	* d_exner(k) * d_seconds_hour
5681	ENDDO
5682
5683	ENDIF
5684
5685	END SUBROUTINE radiation_tendency_ij
5686	#endif
5687
5688
5689	!------------------------------------------------------------------------------!
5690	! Description:
5691	! ------------
5692	!> Calculate temperature tendency due to radiative cooling/heating.
5693	!> Vector-optimized version
5694	!------------------------------------------------------------------------------!
5695	#if defined( __rrtmg )
5696	SUBROUTINE radiation_tendency ( tend )
5697
5698	USE indices, &
5699	ONLY: nxl, nxr, nyn, nys
5700
5701	IMPLICIT NONE
5702
5703	INTEGER(iwp) :: i, j, k !< loop indices
5704
5705	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5706
5707	IF ( radiation_scheme == 'rrtmg' ) THEN
5708	!
5709	!-- Calculate tendency based on heating rate
5710	DO i = nxl, nxr
5711	DO j = nys, nyn
5712	DO k = nzb+1, nzt+1
5713	tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) &
5714	+ rad_sw_hr(k,j,i) ) * d_exner(k) &
5715	* d_seconds_hour
5716	ENDDO
5717	ENDDO
5718	ENDDO
5719	ENDIF
5720
5721	END SUBROUTINE radiation_tendency
5722	#endif
5723
5724	!------------------------------------------------------------------------------!
5725	! Description:
5726	! ------------
5727	!> Radiative Transfer Model (RTM) version 3.0 for modelling of radiation
5728	!> interactions within urban canopy or inside of surface layer in complex terrain.
5729	!> This subroutine calculates interaction of the solar SW and LW radiation
5730	!> with urban and land surfaces and updates all surface heatfluxes.
5731	!> It also calculates interactions of SW and LW radiation with resolved
5732	!> plant canopy and calculates the corresponding plant canopy heat fluxes.
5733	!> The subroutine also models spatial and temporal distribution of Mean
5734	!> Radiant Temperature (MRT). The resulting values are provided to other
5735	!> PALM-4U modules (RRTMG, USM, LSM, PCM and BIO).
5736	!>
5737	!> The new version 3.0 was radically rewriten from version 1.0.
5738	!> The most significant changes include new angular discretization scheme,
5739	!> redesigned and significantly optimized raytracing scheme, new processes
5740	!> included in modelling (e.g. intetrations of LW radiation with PC),
5741	!> integrated calculation of Mean Radiant Temperature (MRT), and improved
5742	!> and enhanced output and debug capabilities. This new version significantly
5743	!> improves effectivity of the paralelization and the scalability of the model
5744	!> and allows simulation of extensive domain with appropriate HPC resources.
5745	!>
5746	!> More info about RTM v.1.0. see:
5747	!> Resler et al., GMD. 2017, https://doi.org/10.5194/gmd-10-3635-2017
5748	!> Info about RTM v. 3.0 see:
5749	!> Krc et al. 2020 (to appear in GMD),
5750	!> Maronga et al., GMDD 2019, https://doi.org/10.5194/gmd-2019-103
5751	!>
5752
5753
5754	!------------------------------------------------------------------------------!
5755
5756	SUBROUTINE radiation_interaction
5757
5758	USE control_parameters, &
5759	ONLY: rotation_angle
5760
5761	IMPLICIT NONE
5762
5763	INTEGER(iwp) :: i, j, k, kk, d, refstep, m, mm, l, ll
5764	INTEGER(iwp) :: isurf, isurfsrc, isvf, icsf, ipcgb
5765	INTEGER(iwp) :: imrt, imrtf
5766	INTEGER(iwp) :: isd !< solar direction number
5767	INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy
5768	INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /)
5769
5770	REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (zyx)
5771	REAL(wp), DIMENSION(3,0:nsurf_type):: vnorm !< face direction normal vectors (zyx)
5772	REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (zyx)
5773	REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx)
5774	REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle
5775	REAL(wp), DIMENSION(nz_urban_b:nz_urban_t) :: pchf_prep !< precalculated factor for canopy temperature tendency
5776	REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff
5777	REAL(wp) :: asrc !< area of source face
5778	REAL(wp) :: pcrad !< irradiance from plant canopy
5779	REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W)
5780	REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W)
5781	REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W)
5782	REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W)
5783	REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5784	REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5785	REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W)
5786	REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W)
5787	REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W)
5788	REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W)
5789	REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor
5790	REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor
5791	REAL(wp) :: area_surfl !< total area of surfaces in local processor
5792	REAL(wp) :: area_surf !< total area of surfaces in all processor
5793	REAL(wp) :: area_hor !< total horizontal area of domain in all processor
5794	#if defined( __parallel )
5795	REAL(wp), DIMENSION(1:7) :: combine_allreduce !< dummy array used to combine several MPI_ALLREDUCE calls
5796	REAL(wp), DIMENSION(1:7) :: combine_allreduce_l !< dummy array used to combine several MPI_ALLREDUCE calls
5797	#endif
5798
5799	IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'start' )
5800
5801	IF ( plant_canopy ) THEN
5802	pchf_prep(:) = r_d * exner(nz_urban_b:nz_urban_t) &
5803	/ (c_p * hyp(nz_urban_b:nz_urban_t) * dxdydz(1)) !< equals to 1 / (rho * c_p * Vbox * T)
5804	ENDIF
5805
5806	sun_direction = .TRUE.
5807	CALL get_date_time( time_since_reference_point, &
5808	day_of_year=day_of_year, &
5809	second_of_day=second_of_day )
5810	CALL calc_zenith( day_of_year, second_of_day ) !< required also for diffusion radiation
5811
5812	!
5813	!-- prepare rotated normal vectors and irradiance factor
5814	vnorm(1,:) = kdir(:)
5815	vnorm(2,:) = jdir(:)
5816	vnorm(3,:) = idir(:)
5817	mrot(1, :) = (/ 1._wp, 0._wp, 0._wp /)
5818	mrot(2, :) = (/ 0._wp, COS(rotation_angle), SIN(rotation_angle) /)
5819	mrot(3, :) = (/ 0._wp, -SIN(rotation_angle), COS(rotation_angle) /)
5820	sunorig = (/ cos_zenith, sun_dir_lat, sun_dir_lon /)
5821	sunorig = MATMUL(mrot, sunorig)
5822	DO d = 0, nsurf_type
5823	costheta(d) = DOT_PRODUCT(sunorig, vnorm(:,d))
5824	ENDDO
5825
5826	IF ( cos_zenith > 0 ) THEN
5827	!-- now we will "squash" the sunorig vector by grid box size in
5828	!-- each dimension, so that this new direction vector will allow us
5829	!-- to traverse the ray path within grid coordinates directly
5830	sunorig_grid = (/ sunorig(1)/dz(1), sunorig(2)/dy, sunorig(3)/dx /)
5831	!-- sunorig_grid = sunorig_grid / norm2(sunorig_grid)
5832	sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2))
5833
5834	IF ( npcbl > 0 ) THEN
5835	!-- precompute effective box depth with prototype Leaf Area Density
5836	pc_box_dimshift = MAXLOC(ABS(sunorig), 1) - 1
5837	CALL box_absorb(CSHIFT((/dz(1),dy,dx/), pc_box_dimshift), &
5838	60, prototype_lad, &
5839	CSHIFT(ABS(sunorig), pc_box_dimshift), &
5840	pc_box_area, pc_abs_frac)
5841	pc_box_area = pc_box_area * ABS(sunorig(pc_box_dimshift+1) &
5842	/ sunorig(1))
5843	pc_abs_eff = LOG(1._wp - pc_abs_frac) / prototype_lad
5844	ENDIF
5845	ENDIF
5846	!
5847	!-- Split downwelling shortwave radiation into a diffuse and a direct part.
5848	!-- Note, if radiation scheme is RRTMG or diffuse radiation is externally
5849	!-- prescribed, this is not required. Please note, in case of external
5850	!-- radiation, the clear-sky model is applied during spinup, so that
5851	!-- radiation need to be split also in this case.
5852	IF ( radiation_scheme == 'constant' .OR. &
5853	radiation_scheme == 'clear-sky' .OR. &
5854	( radiation_scheme == 'external' .AND. &
5855	.NOT. rad_sw_in_dif_f%from_file ) .OR. &
5856	( radiation_scheme == 'external' .AND. &
5857	time_since_reference_point < 0.0_wp ) ) THEN
5858	CALL calc_diffusion_radiation
5859	ENDIF
5860
5861	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5862	!-- First pass: direct + diffuse irradiance + thermal
5863	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5864	surfinswdir = 0._wp !nsurfl
5865	surfins = 0._wp !nsurfl
5866	surfinl = 0._wp !nsurfl
5867	surfoutsl(:) = 0.0_wp !start-end
5868	surfoutll(:) = 0.0_wp !start-end
5869	IF ( nmrtbl > 0 ) THEN
5870	mrtinsw(:) = 0._wp
5871	mrtinlw(:) = 0._wp
5872	ENDIF
5873	surfinlg(:) = 0._wp !global
5874
5875
5876	!-- Set up thermal radiation from surfaces
5877	!-- emiss_surf is defined only for surfaces for which energy balance is calculated
5878	!-- Workaround: reorder surface data type back on 1D array including all surfaces,
5879	!-- which implies to reorder horizontal and vertical surfaces
5880	!
5881	!-- Horizontal walls
5882	mm = 1
5883	DO i = nxl, nxr
5884	DO j = nys, nyn
5885	!-- urban
5886	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
5887	surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * &
5888	surf_usm_h%emissivity(:,m) ) &
5889	* sigma_sb &
5890	* surf_usm_h%pt_surface(m)**4
5891	albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5892	surf_usm_h%albedo(:,m) )
5893	emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5894	surf_usm_h%emissivity(:,m) )
5895	mm = mm + 1
5896	ENDDO
5897	!-- land
5898	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
5899	surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5900	surf_lsm_h%emissivity(:,m) ) &
5901	* sigma_sb &
5902	* surf_lsm_h%pt_surface(m)**4
5903	albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5904	surf_lsm_h%albedo(:,m) )
5905	emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5906	surf_lsm_h%emissivity(:,m) )
5907	mm = mm + 1
5908	ENDDO
5909	ENDDO
5910	ENDDO
5911	!
5912	!-- Vertical walls
5913	DO i = nxl, nxr
5914	DO j = nys, nyn
5915	DO ll = 0, 3
5916	l = reorder(ll)
5917	!-- urban
5918	DO m = surf_usm_v(l)%start_index(j,i), &
5919	surf_usm_v(l)%end_index(j,i)
5920	surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5921	surf_usm_v(l)%emissivity(:,m) ) &
5922	* sigma_sb &
5923	* surf_usm_v(l)%pt_surface(m)**4
5924	albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5925	surf_usm_v(l)%albedo(:,m) )
5926	emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5927	surf_usm_v(l)%emissivity(:,m) )
5928	mm = mm + 1
5929	ENDDO
5930	!-- land
5931	DO m = surf_lsm_v(l)%start_index(j,i), &
5932	surf_lsm_v(l)%end_index(j,i)
5933	surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5934	surf_lsm_v(l)%emissivity(:,m) ) &
5935	* sigma_sb &
5936	* surf_lsm_v(l)%pt_surface(m)**4
5937	albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5938	surf_lsm_v(l)%albedo(:,m) )
5939	emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5940	surf_lsm_v(l)%emissivity(:,m) )
5941	mm = mm + 1
5942	ENDDO
5943	ENDDO
5944	ENDDO
5945	ENDDO
5946
5947	IF ( trace_fluxes_above >= 0._wp ) THEN
5948	CALL radiation_print_debug_surf( 'surfoutll before initial pass', surfoutll )
5949	CALL radiation_print_debug_horz( 'rad_lw_in_diff before initial pass', rad_lw_in_diff )
5950	CALL radiation_print_debug_horz( 'rad_sw_in_diff before initial pass', rad_sw_in_diff )
5951	CALL radiation_print_debug_horz( 'rad_sw_in_dir before initial pass', rad_sw_in_dir )
5952	ENDIF
5953
5954	#if defined( __parallel )
5955	!-- might be optimized and gather only values relevant for current processor
5956	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5957	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global
5958	IF ( ierr /= 0 ) THEN
5959	WRITE(9,*) 'Error MPI_AllGatherv1:', ierr, SIZE(surfoutll), nsurfl, &
5960	SIZE(surfoutl), nsurfs, surfstart
5961	FLUSH(9)
5962	ENDIF
5963	#else
5964	surfoutl(:) = surfoutll(:) !nsurf global
5965	#endif
5966
5967	IF ( surface_reflections) THEN
5968	DO isvf = 1, nsvfl
5969	isurf = svfsurf(1, isvf)
5970	k = surfl(iz, isurf)
5971	j = surfl(iy, isurf)
5972	i = surfl(ix, isurf)
5973	isurfsrc = svfsurf(2, isvf)
5974	!
5975	!-- For surface-to-surface factors we calculate thermal radiation in 1st pass
5976	IF ( plant_lw_interact ) THEN
5977	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
5978	ELSE
5979	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5980	ENDIF
5981	ENDDO
5982	ENDIF
5983	!
5984	!-- diffuse radiation using sky view factor
5985	DO isurf = 1, nsurfl
5986	j = surfl(iy, isurf)
5987	i = surfl(ix, isurf)
5988	surfinswdif(isurf) = rad_sw_in_diff(j,i) * skyvft(isurf)
5989	IF ( plant_lw_interact ) THEN
5990	surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvft(isurf)
5991	ELSE
5992	surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvf(isurf)
5993	ENDIF
5994	ENDDO
5995	!
5996	!-- MRT diffuse irradiance
5997	DO imrt = 1, nmrtbl
5998	j = mrtbl(iy, imrt)
5999	i = mrtbl(ix, imrt)
6000	mrtinsw(imrt) = mrtskyt(imrt) * rad_sw_in_diff(j,i)
6001	mrtinlw(imrt) = mrtsky(imrt) * rad_lw_in_diff(j,i)
6002	ENDDO
6003
6004	!-- direct radiation
6005	IF ( cos_zenith > 0 ) THEN
6006	!--Identify solar direction vector (discretized number) 1)
6007	!--
6008	j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
6009	i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat) &
6010	/ (2._wppi) raytrace_discrete_azims-.5_wp, iwp), &
6011	raytrace_discrete_azims)
6012	isd = dsidir_rev(j, i)
6013	!-- TODO: check if isd = -1 to report that this solar position is not precalculated
6014	DO isurf = 1, nsurfl
6015	j = surfl(iy, isurf)
6016	i = surfl(ix, isurf)
6017	surfinswdir(isurf) = rad_sw_in_dir(j,i) * &
6018	costheta(surfl(id, isurf)) * dsitrans(isurf, isd) / cos_zenith
6019	ENDDO
6020	!
6021	!-- MRT direct irradiance
6022	DO imrt = 1, nmrtbl
6023	j = mrtbl(iy, imrt)
6024	i = mrtbl(ix, imrt)
6025	mrtinsw(imrt) = mrtinsw(imrt) + mrtdsit(imrt, isd) * rad_sw_in_dir(j,i) &
6026	/ cos_zenith / 4._wp ! normal to sphere
6027	ENDDO
6028	ENDIF
6029	!
6030	!-- MRT first pass thermal
6031	DO imrtf = 1, nmrtf
6032	imrt = mrtfsurf(1, imrtf)
6033	isurfsrc = mrtfsurf(2, imrtf)
6034	mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
6035	ENDDO
6036	!
6037	!-- Absorption in each local plant canopy grid box from the first atmospheric
6038	!-- pass of radiation
6039	IF ( npcbl > 0 ) THEN
6040
6041	pcbinswdir(:) = 0._wp
6042	pcbinswdif(:) = 0._wp
6043	pcbinlw(:) = 0._wp
6044
6045	DO icsf = 1, ncsfl
6046	ipcgb = csfsurf(1, icsf)
6047	i = pcbl(ix,ipcgb)
6048	j = pcbl(iy,ipcgb)
6049	k = pcbl(iz,ipcgb)
6050	isurfsrc = csfsurf(2, icsf)
6051
6052	IF ( isurfsrc == -1 ) THEN
6053	!
6054	!-- Diffuse radiation from sky
6055	pcbinswdif(ipcgb) = csf(1,icsf) * rad_sw_in_diff(j,i)
6056	!
6057	!-- Absorbed diffuse LW radiation from sky minus emitted to sky
6058	IF ( plant_lw_interact ) THEN
6059	pcbinlw(ipcgb) = csf(1,icsf) &
6060	* (rad_lw_in_diff(j, i) &
6061	- sigma_sb * (pt(k,j,i)exner(k))*4)
6062	ENDIF
6063	!
6064	!-- Direct solar radiation
6065	IF ( cos_zenith > 0 ) THEN
6066	!-- Estimate directed box absorption
6067	pc_abs_frac = 1._wp - exp(pc_abs_eff * lad_s(k,j,i))
6068	!
6069	!-- isd has already been established, see 1)
6070	pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area &
6071	* pc_abs_frac * dsitransc(ipcgb, isd)
6072	ENDIF
6073	ELSE
6074	IF ( plant_lw_interact ) THEN
6075	!
6076	!-- Thermal emission from plan canopy towards respective face
6077	pcrad = sigma_sb * (pt(k,j,i) * exner(k))*4 csf(1,icsf)
6078	surfinlg(isurfsrc) = surfinlg(isurfsrc) + pcrad
6079	!
6080	!-- Remove the flux above + absorb LW from first pass from surfaces
6081	asrc = facearea(surf(id, isurfsrc))
6082	pcbinlw(ipcgb) = pcbinlw(ipcgb) &
6083	+ (csf(1,icsf) * surfoutl(isurfsrc) & ! Absorb from first pass surf emit
6084	- pcrad) & ! Remove emitted heatflux
6085	* asrc
6086	ENDIF
6087	ENDIF
6088	ENDDO
6089
6090	pcbinsw(:) = pcbinswdir(:) + pcbinswdif(:)
6091	ENDIF
6092
6093	IF ( trace_fluxes_above >= 0._wp ) THEN
6094	CALL radiation_print_debug_surf( 'surfinl after initial pass', surfinl )
6095	CALL radiation_print_debug_surf( 'surfinlwdif after initial pass', surfinlwdif )
6096	CALL radiation_print_debug_surf( 'surfinswdif after initial pass', surfinswdif )
6097	CALL radiation_print_debug_surf( 'surfinswdir after initial pass', surfinswdir )
6098	IF ( npcbl > 0 ) THEN
6099	CALL radiation_print_debug_pcb( 'pcbinlw after initial pass', pcbinlw )
6100	CALL radiation_print_debug_pcb( 'pcbinswdif after initial pass', pcbinswdif )
6101	CALL radiation_print_debug_pcb( 'pcbinswdir after initial pass', pcbinswdir )
6102	ENDIF
6103	ENDIF
6104
6105	IF ( plant_lw_interact ) THEN
6106	!
6107	!-- Exchange incoming lw radiation from plant canopy
6108	#if defined( __parallel )
6109	CALL MPI_Allreduce(MPI_IN_PLACE, surfinlg, nsurf, MPI_REAL, MPI_SUM, comm2d, ierr)
6110	IF ( ierr /= 0 ) THEN
6111	WRITE (9,*) 'Error MPI_Allreduce:', ierr
6112	FLUSH(9)
6113	ENDIF
6114	surfinl(:) = surfinl(:) + surfinlg(surfstart(myid)+1:surfstart(myid+1))
6115	#else
6116	surfinl(:) = surfinl(:) + surfinlg(:)
6117	#endif
6118	ENDIF
6119
6120	IF ( trace_fluxes_above >= 0._wp ) THEN
6121	CALL radiation_print_debug_surf( 'surfinl after PC emiss', surfinl )
6122	ENDIF
6123
6124	surfins = surfinswdir + surfinswdif
6125	surfinl = surfinl + surfinlwdif
6126	surfinsw = surfins
6127	surfinlw = surfinl
6128	surfoutsw = 0.0_wp
6129	surfoutlw = surfoutll
6130	surfemitlwl = surfoutll
6131
6132	IF ( .NOT. surface_reflections ) THEN
6133	!
6134	!-- Set nrefsteps to 0 to disable reflections
6135	nrefsteps = 0
6136	surfoutsl = albedo_surf * surfins
6137	surfoutll = (1._wp - emiss_surf) * surfinl
6138	surfoutsw = surfoutsw + surfoutsl
6139	surfoutlw = surfoutlw + surfoutll
6140	ENDIF
6141
6142	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6143	!-- Next passes - reflections
6144	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6145	DO refstep = 1, nrefsteps
6146
6147	surfoutsl = albedo_surf * surfins
6148	!
6149	!-- for non-transparent surfaces, longwave albedo is 1 - emissivity
6150	surfoutll = (1._wp - emiss_surf) * surfinl
6151
6152	IF ( trace_fluxes_above >= 0._wp ) THEN
6153	CALL radiation_print_debug_surf( 'surfoutll before reflective pass', surfoutll, refstep )
6154	CALL radiation_print_debug_surf( 'surfoutsl before reflective pass', surfoutsl, refstep )
6155	ENDIF
6156
6157	#if defined( __parallel )
6158	CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, &
6159	surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
6160	IF ( ierr /= 0 ) THEN
6161	WRITE(9,*) 'Error MPI_AllGatherv2:', ierr, SIZE(surfoutsl), nsurfl, &
6162	SIZE(surfouts), nsurfs, surfstart
6163	FLUSH(9)
6164	ENDIF
6165
6166	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
6167	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
6168	IF ( ierr /= 0 ) THEN
6169	WRITE(9,*) 'Error MPI_AllGatherv3:', ierr, SIZE(surfoutll), nsurfl, &
6170	SIZE(surfoutl), nsurfs, surfstart
6171	FLUSH(9)
6172	ENDIF
6173
6174	#else
6175	surfouts = surfoutsl
6176	surfoutl = surfoutll
6177	#endif
6178	!
6179	!-- Reset for the input from next reflective pass
6180	surfins = 0._wp
6181	surfinl = 0._wp
6182	!
6183	!-- Reflected radiation
6184	DO isvf = 1, nsvfl
6185	isurf = svfsurf(1, isvf)
6186	isurfsrc = svfsurf(2, isvf)
6187	surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc)
6188	IF ( plant_lw_interact ) THEN
6189	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
6190	ELSE
6191	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
6192	ENDIF
6193	ENDDO
6194	!
6195	!-- NOTE: PC absorbtion and MRT from reflected can both be done at once
6196	!-- after all reflections if we do one more MPI_ALLGATHERV on surfout.
6197	!-- Advantage: less local computation. Disadvantage: one more collective
6198	!-- MPI call.
6199	!
6200	!-- Radiation absorbed by plant canopy
6201	DO icsf = 1, ncsfl
6202	ipcgb = csfsurf(1, icsf)
6203	isurfsrc = csfsurf(2, icsf)
6204	IF ( isurfsrc == -1 ) CYCLE ! sky->face only in 1st pass, not here
6205	!
6206	!-- Calculate source surface area. If the `surf' array is removed
6207	!-- before timestepping starts (future version), then asrc must be
6208	!-- stored within `csf'
6209	asrc = facearea(surf(id, isurfsrc))
6210	pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * surfouts(isurfsrc) * asrc
6211	IF ( plant_lw_interact ) THEN
6212	pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) * asrc
6213	ENDIF
6214	ENDDO
6215	!
6216	!-- MRT reflected
6217	DO imrtf = 1, nmrtf
6218	imrt = mrtfsurf(1, imrtf)
6219	isurfsrc = mrtfsurf(2, imrtf)
6220	mrtinsw(imrt) = mrtinsw(imrt) + mrtft(imrtf) * surfouts(isurfsrc)
6221	mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
6222	ENDDO
6223
6224	IF ( trace_fluxes_above >= 0._wp ) THEN
6225	CALL radiation_print_debug_surf( 'surfinl after reflected pass', surfinl, refstep )
6226	CALL radiation_print_debug_surf( 'surfins after reflected pass', surfins, refstep )
6227	CALL radiation_print_debug_pcb( 'pcbinlw after reflected pass', pcbinlw, refstep )
6228	CALL radiation_print_debug_pcb( 'pcbinsw after reflected pass', pcbinsw, refstep )
6229	ENDIF
6230
6231	surfinsw = surfinsw + surfins
6232	surfinlw = surfinlw + surfinl
6233	surfoutsw = surfoutsw + surfoutsl
6234	surfoutlw = surfoutlw + surfoutll
6235
6236	ENDDO ! refstep
6237
6238	!-- push heat flux absorbed by plant canopy to respective 3D arrays
6239	IF ( npcbl > 0 ) THEN
6240	pcm_heating_rate(:,:,:) = 0.0_wp
6241	DO ipcgb = 1, npcbl
6242	j = pcbl(iy, ipcgb)
6243	i = pcbl(ix, ipcgb)
6244	k = pcbl(iz, ipcgb)
6245	!
6246	!-- Following expression equals former kk = k - nzb_s_inner(j,i)
6247	kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat
6248	pcm_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) &
6249	* pchf_prep(k) * pt(k, j, i) !-- = dT/dt
6250	ENDDO
6251
6252	IF ( humidity .AND. plant_canopy_transpiration ) THEN
6253	!-- Calculation of plant canopy transpiration rate and correspondidng latent heat rate
6254	pcm_transpiration_rate(:,:,:) = 0.0_wp
6255	pcm_latent_rate(:,:,:) = 0.0_wp
6256	DO ipcgb = 1, npcbl
6257	i = pcbl(ix, ipcgb)
6258	j = pcbl(iy, ipcgb)
6259	k = pcbl(iz, ipcgb)
6260	kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat
6261	CALL pcm_calc_transpiration_rate( i, j, k, kk, pcbinsw(ipcgb), pcbinlw(ipcgb), &
6262	pcm_transpiration_rate(kk,j,i), pcm_latent_rate(kk,j,i) )
6263	ENDDO
6264	ENDIF
6265	ENDIF
6266	!
6267	!-- Calculate black body MRT (after all reflections)
6268	IF ( nmrtbl > 0 ) THEN
6269	IF ( mrt_include_sw ) THEN
6270	mrt(:) = ((mrtinsw(:) + mrtinlw(:)) / sigma_sb) ** .25_wp
6271	ELSE
6272	mrt(:) = (mrtinlw(:) / sigma_sb) ** .25_wp
6273	ENDIF
6274	ENDIF
6275	!
6276	!-- Transfer radiation arrays required for energy balance to the respective data types
6277	DO i = 1, nsurfl
6278	m = surfl(im,i)
6279	!
6280	!-- (1) Urban surfaces
6281	!-- upward-facing
6282	IF ( surfl(1,i) == iup_u ) THEN
6283	surf_usm_h%rad_sw_in(m) = surfinsw(i)
6284	surf_usm_h%rad_sw_out(m) = surfoutsw(i)
6285	surf_usm_h%rad_sw_dir(m) = surfinswdir(i)
6286	surf_usm_h%rad_sw_dif(m) = surfinswdif(i)
6287	surf_usm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6288	surfinswdif(i)
6289	surf_usm_h%rad_sw_res(m) = surfins(i)
6290	surf_usm_h%rad_lw_in(m) = surfinlw(i)
6291	surf_usm_h%rad_lw_out(m) = surfoutlw(i)
6292	surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6293	surfinlw(i) - surfoutlw(i)
6294	surf_usm_h%rad_net_l(m) = surf_usm_h%rad_net(m)
6295	surf_usm_h%rad_lw_dif(m) = surfinlwdif(i)
6296	surf_usm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6297	surf_usm_h%rad_lw_res(m) = surfinl(i)
6298	!
6299	!-- northward-facding
6300	ELSEIF ( surfl(1,i) == inorth_u ) THEN
6301	surf_usm_v(0)%rad_sw_in(m) = surfinsw(i)
6302	surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i)
6303	surf_usm_v(0)%rad_sw_dir(m) = surfinswdir(i)
6304	surf_usm_v(0)%rad_sw_dif(m) = surfinswdif(i)
6305	surf_usm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6306	surfinswdif(i)
6307	surf_usm_v(0)%rad_sw_res(m) = surfins(i)
6308	surf_usm_v(0)%rad_lw_in(m) = surfinlw(i)
6309	surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i)
6310	surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6311	surfinlw(i) - surfoutlw(i)
6312	surf_usm_v(0)%rad_net_l(m) = surf_usm_v(0)%rad_net(m)
6313	surf_usm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
6314	surf_usm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6315	surf_usm_v(0)%rad_lw_res(m) = surfinl(i)
6316	!
6317	!-- southward-facding
6318	ELSEIF ( surfl(1,i) == isouth_u ) THEN
6319	surf_usm_v(1)%rad_sw_in(m) = surfinsw(i)
6320	surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i)
6321	surf_usm_v(1)%rad_sw_dir(m) = surfinswdir(i)
6322	surf_usm_v(1)%rad_sw_dif(m) = surfinswdif(i)
6323	surf_usm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6324	surfinswdif(i)
6325	surf_usm_v(1)%rad_sw_res(m) = surfins(i)
6326	surf_usm_v(1)%rad_lw_in(m) = surfinlw(i)
6327	surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i)
6328	surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6329	surfinlw(i) - surfoutlw(i)
6330	surf_usm_v(1)%rad_net_l(m) = surf_usm_v(1)%rad_net(m)
6331	surf_usm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
6332	surf_usm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6333	surf_usm_v(1)%rad_lw_res(m) = surfinl(i)
6334	!
6335	!-- eastward-facing
6336	ELSEIF ( surfl(1,i) == ieast_u ) THEN
6337	surf_usm_v(2)%rad_sw_in(m) = surfinsw(i)
6338	surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i)
6339	surf_usm_v(2)%rad_sw_dir(m) = surfinswdir(i)
6340	surf_usm_v(2)%rad_sw_dif(m) = surfinswdif(i)
6341	surf_usm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6342	surfinswdif(i)
6343	surf_usm_v(2)%rad_sw_res(m) = surfins(i)
6344	surf_usm_v(2)%rad_lw_in(m) = surfinlw(i)
6345	surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i)
6346	surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6347	surfinlw(i) - surfoutlw(i)
6348	surf_usm_v(2)%rad_net_l(m) = surf_usm_v(2)%rad_net(m)
6349	surf_usm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
6350	surf_usm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6351	surf_usm_v(2)%rad_lw_res(m) = surfinl(i)
6352	!
6353	!-- westward-facding
6354	ELSEIF ( surfl(1,i) == iwest_u ) THEN
6355	surf_usm_v(3)%rad_sw_in(m) = surfinsw(i)
6356	surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i)
6357	surf_usm_v(3)%rad_sw_dir(m) = surfinswdir(i)
6358	surf_usm_v(3)%rad_sw_dif(m) = surfinswdif(i)
6359	surf_usm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6360	surfinswdif(i)
6361	surf_usm_v(3)%rad_sw_res(m) = surfins(i)
6362	surf_usm_v(3)%rad_lw_in(m) = surfinlw(i)
6363	surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i)
6364	surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6365	surfinlw(i) - surfoutlw(i)
6366	surf_usm_v(3)%rad_net_l(m) = surf_usm_v(3)%rad_net(m)
6367	surf_usm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
6368	surf_usm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6369	surf_usm_v(3)%rad_lw_res(m) = surfinl(i)
6370	!
6371	!-- (2) land surfaces
6372	!-- upward-facing
6373	ELSEIF ( surfl(1,i) == iup_l ) THEN
6374	surf_lsm_h%rad_sw_in(m) = surfinsw(i)
6375	surf_lsm_h%rad_sw_out(m) = surfoutsw(i)
6376	surf_lsm_h%rad_sw_dir(m) = surfinswdir(i)
6377	surf_lsm_h%rad_sw_dif(m) = surfinswdif(i)
6378	surf_lsm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6379	surfinswdif(i)
6380	surf_lsm_h%rad_sw_res(m) = surfins(i)
6381	surf_lsm_h%rad_lw_in(m) = surfinlw(i)
6382	surf_lsm_h%rad_lw_out(m) = surfoutlw(i)
6383	surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6384	surfinlw(i) - surfoutlw(i)
6385	surf_lsm_h%rad_lw_dif(m) = surfinlwdif(i)
6386	surf_lsm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6387	surf_lsm_h%rad_lw_res(m) = surfinl(i)
6388	!
6389	!-- northward-facding
6390	ELSEIF ( surfl(1,i) == inorth_l ) THEN
6391	surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i)
6392	surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i)
6393	surf_lsm_v(0)%rad_sw_dir(m) = surfinswdir(i)
6394	surf_lsm_v(0)%rad_sw_dif(m) = surfinswdif(i)
6395	surf_lsm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6396	surfinswdif(i)
6397	surf_lsm_v(0)%rad_sw_res(m) = surfins(i)
6398	surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i)
6399	surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i)
6400	surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6401	surfinlw(i) - surfoutlw(i)
6402	surf_lsm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
6403	surf_lsm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6404	surf_lsm_v(0)%rad_lw_res(m) = surfinl(i)
6405	!
6406	!-- southward-facding
6407	ELSEIF ( surfl(1,i) == isouth_l ) THEN
6408	surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i)
6409	surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i)
6410	surf_lsm_v(1)%rad_sw_dir(m) = surfinswdir(i)
6411	surf_lsm_v(1)%rad_sw_dif(m) = surfinswdif(i)
6412	surf_lsm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6413	surfinswdif(i)
6414	surf_lsm_v(1)%rad_sw_res(m) = surfins(i)
6415	surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i)
6416	surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i)
6417	surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6418	surfinlw(i) - surfoutlw(i)
6419	surf_lsm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
6420	surf_lsm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6421	surf_lsm_v(1)%rad_lw_res(m) = surfinl(i)
6422	!
6423	!-- eastward-facing
6424	ELSEIF ( surfl(1,i) == ieast_l ) THEN
6425	surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i)
6426	surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i)
6427	surf_lsm_v(2)%rad_sw_dir(m) = surfinswdir(i)
6428	surf_lsm_v(2)%rad_sw_dif(m) = surfinswdif(i)
6429	surf_lsm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6430	surfinswdif(i)
6431	surf_lsm_v(2)%rad_sw_res(m) = surfins(i)
6432	surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i)
6433	surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i)
6434	surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6435	surfinlw(i) - surfoutlw(i)
6436	surf_lsm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
6437	surf_lsm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6438	surf_lsm_v(2)%rad_lw_res(m) = surfinl(i)
6439	!
6440	!-- westward-facing
6441	ELSEIF ( surfl(1,i) == iwest_l ) THEN
6442	surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i)
6443	surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i)
6444	surf_lsm_v(3)%rad_sw_dir(m) = surfinswdir(i)
6445	surf_lsm_v(3)%rad_sw_dif(m) = surfinswdif(i)
6446	surf_lsm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6447	surfinswdif(i)
6448	surf_lsm_v(3)%rad_sw_res(m) = surfins(i)
6449	surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i)
6450	surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i)
6451	surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6452	surfinlw(i) - surfoutlw(i)
6453	surf_lsm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
6454	surf_lsm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6455	surf_lsm_v(3)%rad_lw_res(m) = surfinl(i)
6456	ENDIF
6457
6458	ENDDO
6459
6460	DO m = 1, surf_usm_h%ns
6461	surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + &
6462	surf_usm_h%rad_lw_in(m) - &
6463	surf_usm_h%rad_sw_out(m) - &
6464	surf_usm_h%rad_lw_out(m)
6465	ENDDO
6466	DO m = 1, surf_lsm_h%ns
6467	surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + &
6468	surf_lsm_h%rad_lw_in(m) - &
6469	surf_lsm_h%rad_sw_out(m) - &
6470	surf_lsm_h%rad_lw_out(m)
6471	ENDDO
6472
6473	DO l = 0, 3
6474	!-- urban
6475	DO m = 1, surf_usm_v(l)%ns
6476	surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + &
6477	surf_usm_v(l)%rad_lw_in(m) - &
6478	surf_usm_v(l)%rad_sw_out(m) - &
6479	surf_usm_v(l)%rad_lw_out(m)
6480	ENDDO
6481	!-- land
6482	DO m = 1, surf_lsm_v(l)%ns
6483	surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + &
6484	surf_lsm_v(l)%rad_lw_in(m) - &
6485	surf_lsm_v(l)%rad_sw_out(m) - &
6486	surf_lsm_v(l)%rad_lw_out(m)
6487
6488	ENDDO
6489	ENDDO
6490	!
6491	!-- Calculate the average temperature, albedo, and emissivity for urban/land
6492	!-- domain when using average_radiation in the respective radiation model
6493
6494	!-- calculate horizontal area
6495	! !!! ATTENTION!!! uniform grid is assumed here
6496	area_hor = (nx+1) * (ny+1) * dx * dy
6497	!
6498	!-- absorbed/received SW & LW and emitted LW energy of all physical
6499	!-- surfaces (land and urban) in local processor
6500	pinswl = 0._wp
6501	pinlwl = 0._wp
6502	pabsswl = 0._wp
6503	pabslwl = 0._wp
6504	pemitlwl = 0._wp
6505	emiss_sum_surfl = 0._wp
6506	area_surfl = 0._wp
6507	DO i = 1, nsurfl
6508	d = surfl(id, i)
6509	!-- received SW & LW
6510	pinswl = pinswl + (surfinswdir(i) + surfinswdif(i)) * facearea(d)
6511	pinlwl = pinlwl + surfinlwdif(i) * facearea(d)
6512	!-- absorbed SW & LW
6513	pabsswl = pabsswl + (1._wp - albedo_surf(i)) * &
6514	surfinsw(i) * facearea(d)
6515	pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d)
6516	!-- emitted LW
6517	pemitlwl = pemitlwl + surfemitlwl(i) * facearea(d)
6518	!-- emissivity and area sum
6519	emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d)
6520	area_surfl = area_surfl + facearea(d)
6521	END DO
6522	!
6523	!-- add the absorbed SW energy by plant canopy
6524	IF ( npcbl > 0 ) THEN
6525	pabsswl = pabsswl + SUM(pcbinsw)
6526	pabslwl = pabslwl + SUM(pcbinlw)
6527	pinswl = pinswl + SUM(pcbinswdir) + SUM(pcbinswdif)
6528	ENDIF
6529	!
6530	!-- gather all rad flux energy in all processors. In order to reduce
6531	!-- the number of MPI calls (to reduce latencies), combine the required
6532	!-- quantities in one array, sum it up, and subsequently re-distribute
6533	!-- back to the respective quantities.
6534	#if defined( __parallel )
6535	combine_allreduce_l(1) = pinswl
6536	combine_allreduce_l(2) = pinlwl
6537	combine_allreduce_l(3) = pabsswl
6538	combine_allreduce_l(4) = pabslwl
6539	combine_allreduce_l(5) = pemitlwl
6540	combine_allreduce_l(6) = emiss_sum_surfl
6541	combine_allreduce_l(7) = area_surfl
6542
6543	CALL MPI_ALLREDUCE( combine_allreduce_l, &
6544	combine_allreduce, &
6545	SIZE( combine_allreduce ), &
6546	MPI_REAL, &
6547	MPI_SUM, &
6548	comm2d, &
6549	ierr )
6550
6551	pinsw = combine_allreduce(1)
6552	pinlw = combine_allreduce(2)
6553	pabssw = combine_allreduce(3)
6554	pabslw = combine_allreduce(4)
6555	pemitlw = combine_allreduce(5)
6556	emiss_sum_surf = combine_allreduce(6)
6557	area_surf = combine_allreduce(7)
6558	#else
6559	pinsw = pinswl
6560	pinlw = pinlwl
6561	pabssw = pabsswl
6562	pabslw = pabslwl
6563	pemitlw = pemitlwl
6564	emiss_sum_surf = emiss_sum_surfl
6565	area_surf = area_surfl
6566	#endif
6567
6568	!-- (1) albedo
6569	IF ( pinsw /= 0.0_wp ) albedo_urb = ( pinsw - pabssw ) / pinsw
6570	!-- (2) average emmsivity
6571	IF ( area_surf /= 0.0_wp ) emissivity_urb = emiss_sum_surf / area_surf
6572	!
6573	!-- Temporally comment out calculation of effective radiative temperature.
6574	!-- See below for more explanation.
6575	!-- (3) temperature
6576	!-- first we calculate an effective horizontal area to account for
6577	!-- the effect of vertical surfaces (which contributes to LW emission)
6578	!-- We simply use the ratio of the total LW to the incoming LW flux
6579	area_hor = pinlw / rad_lw_in_diff(nyn,nxl)
6580	t_rad_urb = ( ( pemitlw - pabslw + emissivity_urb * pinlw ) / &
6581	(emissivity_urb * sigma_sb * area_hor) )**0.25_wp
6582
6583	IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'end' )
6584
6585
6586	CONTAINS
6587
6588	!------------------------------------------------------------------------------!
6589	!> Calculates radiation absorbed by box with given size and LAD.
6590	!>
6591	!> Simulates resol**2 rays (by equally spacing a bounding horizontal square
6592	!> conatining all possible rays that would cross the box) and calculates
6593	!> average transparency per ray. Returns fraction of absorbed radiation flux
6594	!> and area for which this fraction is effective.
6595	!------------------------------------------------------------------------------!
6596	PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb)
6597	IMPLICIT NONE
6598
6599	REAL(wp), DIMENSION(3), INTENT(in) :: &
6600	boxsize, & !< z, y, x size of box in m
6601	uvec !< z, y, x unit vector of incoming flux
6602	INTEGER(iwp), INTENT(in) :: &
6603	resol !< No. of rays in x and y dimensions
6604	REAL(wp), INTENT(in) :: &
6605	dens !< box density (e.g. Leaf Area Density)
6606	REAL(wp), INTENT(out) :: &
6607	area, & !< horizontal area for flux absorbtion
6608	absorb !< fraction of absorbed flux
6609	REAL(wp) :: &
6610	xshift, yshift, &
6611	xmin, xmax, ymin, ymax, &
6612	xorig, yorig, &
6613	dx1, dy1, dz1, dx2, dy2, dz2, &
6614	crdist, &
6615	transp
6616	INTEGER(iwp) :: &
6617	i, j
6618
6619	xshift = uvec(3) / uvec(1) * boxsize(1)
6620	xmin = min(0._wp, -xshift)
6621	xmax = boxsize(3) + max(0._wp, -xshift)
6622	yshift = uvec(2) / uvec(1) * boxsize(1)
6623	ymin = min(0._wp, -yshift)
6624	ymax = boxsize(2) + max(0._wp, -yshift)
6625
6626	transp = 0._wp
6627	DO i = 1, resol
6628	xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol
6629	DO j = 1, resol
6630	yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol
6631
6632	dz1 = 0._wp
6633	dz2 = boxsize(1)/uvec(1)
6634
6635	IF ( uvec(2) > 0._wp ) THEN
6636	dy1 = -yorig / uvec(2) !< crossing with y=0
6637	dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)
6638	ELSE !uvec(2)==0
6639	dy1 = -huge(1._wp)
6640	dy2 = huge(1._wp)
6641	ENDIF
6642
6643	IF ( uvec(3) > 0._wp ) THEN
6644	dx1 = -xorig / uvec(3) !< crossing with x=0
6645	dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)
6646	ELSE !uvec(3)==0
6647	dx1 = -huge(1._wp)
6648	dx2 = huge(1._wp)
6649	ENDIF
6650
6651	crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1)))
6652	transp = transp + exp(-ext_coef * dens * crdist)
6653	ENDDO
6654	ENDDO
6655	transp = transp / resol**2
6656	area = (boxsize(3)+xshift)*(boxsize(2)+yshift)
6657	absorb = 1._wp - transp
6658
6659	END SUBROUTINE box_absorb
6660
6661	!------------------------------------------------------------------------------!
6662	! Description:
6663	! ------------
6664	!> This subroutine splits direct and diffusion dw radiation for RTM processing.
6665	!> It sould not be called in case the radiation model already does it
6666	!> It follows Boland, Ridley & Brown (2008)
6667	!------------------------------------------------------------------------------!
6668	SUBROUTINE calc_diffusion_radiation
6669
6670	USE palm_date_time_mod, &
6671	ONLY: seconds_per_day
6672
6673	INTEGER(iwp) :: i !< grid index x-direction
6674	INTEGER(iwp) :: j !< grid index y-direction
6675	INTEGER(iwp) :: days_per_year !< days in the current year
6676
6677	REAL(wp) :: clearnessIndex !< clearness index
6678	REAL(wp) :: corrected_solarUp !< corrected solar up radiation
6679	REAL(wp) :: diff_frac !< diffusion fraction of the radiation
6680	REAL(wp) :: etr !< extraterestrial radiation
6681	REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation
6682	REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation
6683	REAL(wp) :: second_of_year !< current second of the year
6684	REAL(wp) :: year_angle !< angle
6685
6686	!
6687	!-- Calculate current day and time based on the initial values and simulation time
6688	CALL get_date_time( time_since_reference_point, &
6689	second_of_year = second_of_year, &
6690	days_per_year = days_per_year )
6691	year_angle = second_of_year / ( REAL( days_per_year, KIND=wp ) * seconds_per_day ) &
6692	* 2.0_wp * pi
6693
6694	etr = solar_constant * (1.00011_wp + &
6695	0.034221_wp * cos(year_angle) + &
6696	0.001280_wp * sin(year_angle) + &
6697	0.000719_wp * cos(2.0_wp * year_angle) + &
6698	0.000077_wp * sin(2.0_wp * year_angle))
6699
6700	!--
6701	!-- Under a very low angle, we keep extraterestrial radiation at
6702	!-- the last small value, therefore the clearness index will be pushed
6703	!-- towards 0 while keeping full continuity.
6704	IF ( cos_zenith <= lowest_solarUp ) THEN
6705	corrected_solarUp = lowest_solarUp
6706	ELSE
6707	corrected_solarUp = cos_zenith
6708	ENDIF
6709
6710	horizontalETR = etr * corrected_solarUp
6711
6712	DO i = nxl, nxr
6713	DO j = nys, nyn
6714	clearnessIndex = rad_sw_in(0,j,i) / horizontalETR
6715	diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))
6716	rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac
6717	rad_sw_in_dir(j,i) = rad_sw_in(0,j,i) * (1.0_wp - diff_frac)
6718	rad_lw_in_diff(j,i) = rad_lw_in(0,j,i)
6719	ENDDO
6720	ENDDO
6721
6722	END SUBROUTINE calc_diffusion_radiation
6723
6724	!------------------------------------------------------------------------------!
6725	! Description:
6726	! ------------
6727	!> Print consecutive radiative extremes if requested to trace early radiation
6728	!> interaction instabilities.
6729	!------------------------------------------------------------------------------!
6730	SUBROUTINE radiation_print_debug_surf( description, values, step )
6731
6732	CHARACTER (LEN=*), INTENT(in) :: description
6733	REAL(wp), DIMENSION(:), INTENT(in) :: values
6734	INTEGER(iwp), INTENT(in), OPTIONAL :: step
6735
6736	CHARACTER (LEN=50) :: location
6737	CHARACTER (LEN=1024) :: debug_string
6738	INTEGER :: isurf
6739	REAL(wp) :: x
6740
6741	isurf = MAXLOC( values, DIM=1 )
6742	x = values(isurf)
6743	IF ( x < trace_fluxes_above ) RETURN
6744
6745	IF ( PRESENT( step ) ) THEN
6746	WRITE( location, '(A," #",I0)' ) description, step
6747	ELSE
6748	location = description
6749	ENDIF
6750
6751	WRITE( debug_string, '("Maximum of ",A50," = ",F12.1," at coords ' // &
6752	'i=",I4,", j=",I4,", k=",I4,", d=",I1,". ' // &
6753	'Alb=",F7.3,", emis=",F7.3)' ) &
6754	location, x, surfl(ix,isurf), surfl(iy,isurf), &
6755	surfl(iz,isurf), surfl(id,isurf), albedo_surf(isurf), &
6756	emiss_surf(isurf)
6757	CALL debug_message( debug_string, 'info' )
6758
6759	END SUBROUTINE
6760
6761	SUBROUTINE radiation_print_debug_pcb( description, values, step )
6762
6763	CHARACTER (LEN=*), INTENT(in) :: description
6764	REAL(wp), DIMENSION(:), INTENT(in) :: values
6765	INTEGER(iwp), INTENT(in), OPTIONAL :: step
6766
6767	CHARACTER (LEN=50) :: location
6768	CHARACTER (LEN=1024) :: debug_string
6769	INTEGER :: ipcb
6770	REAL(wp) :: x
6771
6772	IF ( npcbl <= 0 ) RETURN
6773	ipcb = MAXLOC( values, DIM=1 )
6774	x = values(ipcb) / (dxdydz(1))
6775	IF ( x < trace_fluxes_above ) RETURN
6776
6777	IF ( PRESENT( step ) ) THEN
6778	WRITE( location, '(A," #",I0)' ) description, step
6779	ELSE
6780	location = description
6781	ENDIF
6782
6783	WRITE( debug_string, '("Maximum of ",A50," = ",F12.1," at coords ' // &
6784	'i=",I4,", j=",I4,", k=",I4)' ) &
6785	location, x, pcbl(ix,ipcb), pcbl(iy,ipcb), pcbl(iz,ipcb)
6786	CALL debug_message( debug_string, 'info' )
6787
6788	END SUBROUTINE
6789
6790	SUBROUTINE radiation_print_debug_horz( description, values, step )
6791
6792	CHARACTER (LEN=*), INTENT(in) :: description
6793	REAL(wp), DIMENSION(:,:), INTENT(in) :: values
6794	INTEGER(iwp), INTENT(in), OPTIONAL :: step
6795
6796	CHARACTER (LEN=50) :: location
6797	CHARACTER (LEN=1024) :: debug_string
6798	INTEGER, DIMENSION(2) :: ji
6799	REAL(wp) :: x
6800
6801	ji = MAXLOC( values )
6802	x = values(ji(1),ji(2))
6803	IF ( x < trace_fluxes_above ) RETURN
6804
6805	IF ( PRESENT( step ) ) THEN
6806	WRITE( location, '(A," #",I0)' ) description, step
6807	ELSE
6808	location = description
6809	ENDIF
6810
6811	WRITE( debug_string, '("Maximum of ",A50," = ",F12.1," at coords ' // &
6812	'i=",I4,", j=",I4)' ) &
6813	location, x, ji(2), ji(1)
6814	CALL debug_message( debug_string, 'info' )
6815
6816	END SUBROUTINE
6817
6818	END SUBROUTINE radiation_interaction
6819
6820	!------------------------------------------------------------------------------!
6821	! Description:
6822	! ------------
6823	!> This subroutine initializes structures needed for Radiative Transfer
6824	!> Model (RTM). This model calculates transformation processes of the
6825	!> radiation inside urban and land canopy layer. The module includes also
6826	!> the interaction of the radiation with the resolved plant canopy.
6827	!>
6828	!------------------------------------------------------------------------------!
6829	SUBROUTINE radiation_interaction_init
6830
6831	USE control_parameters, &
6832	ONLY: dz_stretch_level_start
6833
6834	USE plant_canopy_model_mod, &
6835	ONLY: lad_s
6836
6837	IMPLICIT NONE
6838
6839	INTEGER(iwp) :: i, j, k, l, m, d
6840	INTEGER(iwp) :: k_topo !< vertical index indicating topography top for given (j,i)
6841	INTEGER(iwp) :: nzptl, nzubl, nzutl, isurf, ipcgb, imrt
6842	REAL(wp) :: mrl
6843	#if defined( __parallel )
6844	INTEGER(iwp), DIMENSION(:), POINTER, SAVE :: gridsurf_rma !< fortran pointer, but lower bounds are 1
6845	TYPE(c_ptr) :: gridsurf_rma_p !< allocated c pointer
6846	INTEGER(iwp) :: minfo !< MPI RMA window info handle
6847	#endif
6848
6849	!
6850	!-- precalculate face areas for different face directions using normal vector
6851	DO d = 0, nsurf_type
6852	facearea(d) = 1._wp
6853	IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx
6854	IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy
6855	IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz(1)
6856	ENDDO
6857	!
6858	!-- Find nz_urban_b, nz_urban_t, nz_urban via wall_flag_0 array (nzb_s_inner will be
6859	!-- removed later). The following contruct finds the lowest / largest index
6860	!-- for any upward-facing wall (see bit 12).
6861	nzubl = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6862	nzutl = MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6863
6864	nzubl = MAX( nzubl, nzb )
6865
6866	IF ( plant_canopy ) THEN
6867	!-- allocate needed arrays
6868	ALLOCATE( pct(nys:nyn,nxl:nxr) )
6869	ALLOCATE( pch(nys:nyn,nxl:nxr) )
6870
6871	!-- calculate plant canopy height
6872	npcbl = 0
6873	pct = 0
6874	pch = 0
6875	DO i = nxl, nxr
6876	DO j = nys, nyn
6877	!
6878	!-- Find topography top index
6879	k_topo = topo_top_ind(j,i,0)
6880
6881	DO k = nzt+1, 0, -1
6882	IF ( lad_s(k,j,i) /= 0.0_wp ) THEN
6883	!-- we are at the top of the pcs
6884	pct(j,i) = k + k_topo
6885	pch(j,i) = k
6886	npcbl = npcbl + pch(j,i)
6887	EXIT
6888	ENDIF
6889	ENDDO
6890	ENDDO
6891	ENDDO
6892
6893	nzutl = MAX( nzutl, MAXVAL( pct ) )
6894	nzptl = MAXVAL( pct )
6895
6896	prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere
6897	IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp
6898	!WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' &
6899	! // 'depth using prototype leaf area density = ', prototype_lad
6900	!CALL message('radiation_interaction_init', 'PA0520', 0, 0, -1, 6, 0)
6901	ENDIF
6902
6903	nzutl = MIN( nzutl + nzut_free, nzt )
6904
6905	#if defined( __parallel )
6906	CALL MPI_AllReduce(nzubl, nz_urban_b, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr )
6907	IF ( ierr /= 0 ) THEN
6908	WRITE(9,*) 'Error MPI_AllReduce11:', ierr, nzubl, nz_urban_b
6909	FLUSH(9)
6910	ENDIF
6911	CALL MPI_AllReduce(nzutl, nz_urban_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6912	IF ( ierr /= 0 ) THEN
6913	WRITE(9,*) 'Error MPI_AllReduce12:', ierr, nzutl, nz_urban_t
6914	FLUSH(9)
6915	ENDIF
6916	CALL MPI_AllReduce(nzptl, nz_plant_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6917	IF ( ierr /= 0 ) THEN
6918	WRITE(9,*) 'Error MPI_AllReduce13:', ierr, nzptl, nz_plant_t
6919	FLUSH(9)
6920	ENDIF
6921	#else
6922	nz_urban_b = nzubl
6923	nz_urban_t = nzutl
6924	nz_plant_t = nzptl
6925	#endif
6926	!
6927	!-- Stretching (non-uniform grid spacing) is not considered in the radiation
6928	!-- model. Therefore, vertical stretching has to be applied above the area
6929	!-- where the parts of the radiation model which assume constant grid spacing
6930	!-- are active. ABS (...) is required because the default value of
6931	!-- dz_stretch_level_start is -9999999.9_wp (negative).
6932	IF ( ABS( dz_stretch_level_start(1) ) <= zw(nz_urban_t) ) THEN
6933	WRITE( message_string, * ) 'The lowest level where vertical ', &
6934	'stretching is applied have to be ', &
6935	'greater than ', zw(nz_urban_t)
6936	CALL message( 'radiation_interaction_init', 'PA0496', 1, 2, 0, 6, 0 )
6937	ENDIF
6938	!
6939	!-- global number of urban and plant layers
6940	nz_urban = nz_urban_t - nz_urban_b + 1
6941	nz_plant = nz_plant_t - nz_urban_b + 1
6942	!
6943	!-- check max_raytracing_dist relative to urban surface layer height
6944	mrl = 2.0_wp * nz_urban * dz(1)
6945	!-- set max_raytracing_dist to double the urban surface layer height, if not set
6946	IF ( max_raytracing_dist == -999.0_wp ) THEN
6947	max_raytracing_dist = mrl
6948	ENDIF
6949	!-- check if max_raytracing_dist set too low (here we only warn the user. Other
6950	! option is to correct the value again to double the urban surface layer height)
6951	IF ( max_raytracing_dist < mrl ) THEN
6952	WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist is set less than ' // &
6953	'double the urban surface layer height, i.e. ', mrl
6954	CALL message('radiation_interaction_init', 'PA0521', 0, 0, 0, 6, 0 )
6955	ENDIF
6956	! IF ( max_raytracing_dist <= mrl ) THEN
6957	! IF ( max_raytracing_dist /= -999.0_wp ) THEN
6958	! !-- max_raytracing_dist too low
6959	! WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' &
6960	! // 'override to value ', mrl
6961	! CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0)
6962	! ENDIF
6963	! max_raytracing_dist = mrl
6964	! ENDIF
6965	!
6966	!-- allocate urban surfaces grid
6967	!-- calc number of surfaces in local proc
6968	IF ( debug_output ) CALL debug_message( 'calculation of indices for surfaces', 'info' )
6969
6970	nsurfl = 0
6971	!
6972	!-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that
6973	!-- All horizontal surface elements are already counted in surface_mod.
6974	startland = 1
6975	nsurfl = surf_usm_h%ns + surf_lsm_h%ns
6976	endland = nsurfl
6977	nlands = endland - startland + 1
6978
6979	!
6980	!-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are
6981	!-- already counted in surface_mod.
6982	startwall = nsurfl+1
6983	DO i = 0,3
6984	nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns
6985	ENDDO
6986	endwall = nsurfl
6987	nwalls = endwall - startwall + 1
6988	dirstart = (/ startland, startwall, startwall, startwall, startwall /)
6989	dirend = (/ endland, endwall, endwall, endwall, endwall /)
6990
6991	!-- fill gridpcbl and pcbl
6992	IF ( npcbl > 0 ) THEN
6993	ALLOCATE( pcbl(iz:ix, 1:npcbl) )
6994	ALLOCATE( gridpcbl(nz_urban_b:nz_plant_t,nys:nyn,nxl:nxr) )
6995	pcbl = -1
6996	gridpcbl(:,:,:) = 0
6997	ipcgb = 0
6998	DO i = nxl, nxr
6999	DO j = nys, nyn
7000	!
7001	!-- Find topography top index
7002	k_topo = topo_top_ind(j,i,0)
7003
7004	DO k = k_topo + 1, pct(j,i)
7005	ipcgb = ipcgb + 1
7006	gridpcbl(k,j,i) = ipcgb
7007	pcbl(:,ipcgb) = (/ k, j, i /)
7008	ENDDO
7009	ENDDO
7010	ENDDO
7011	ALLOCATE( pcbinsw( 1:npcbl ) )
7012	ALLOCATE( pcbinswdir( 1:npcbl ) )
7013	ALLOCATE( pcbinswdif( 1:npcbl ) )
7014	ALLOCATE( pcbinlw( 1:npcbl ) )
7015	ENDIF
7016
7017	!
7018	!-- Fill surfl (the ordering of local surfaces given by the following
7019	!-- cycles must not be altered, certain file input routines may depend
7020	!-- on it).
7021	!
7022	!-- We allocate the array as linear and then use a two-dimensional pointer
7023	!-- into it, because some MPI implementations crash with 2D-allocated arrays.
7024	ALLOCATE(surfl_linear(nidx_surf*nsurfl))
7025	surfl(1:nidx_surf,1:nsurfl) => surfl_linear(1:nidx_surf*nsurfl)
7026	isurf = 0
7027	IF ( rad_angular_discretization ) THEN
7028	!
7029	!-- Allocate and fill the reverse indexing array gridsurf
7030	#if defined( __parallel )
7031	!
7032	!-- raytrace_mpi_rma is asserted
7033
7034	CALL MPI_Info_create(minfo, ierr)
7035	IF ( ierr /= 0 ) THEN
7036	WRITE(9,*) 'Error MPI_Info_create1:', ierr
7037	FLUSH(9)
7038	ENDIF
7039	CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
7040	IF ( ierr /= 0 ) THEN
7041	WRITE(9,*) 'Error MPI_Info_set1:', ierr
7042	FLUSH(9)
7043	ENDIF
7044	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
7045	IF ( ierr /= 0 ) THEN
7046	WRITE(9,*) 'Error MPI_Info_set2:', ierr
7047	FLUSH(9)
7048	ENDIF
7049	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
7050	IF ( ierr /= 0 ) THEN
7051	WRITE(9,*) 'Error MPI_Info_set3:', ierr
7052	FLUSH(9)
7053	ENDIF
7054	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
7055	IF ( ierr /= 0 ) THEN
7056	WRITE(9,*) 'Error MPI_Info_set4:', ierr
7057	FLUSH(9)
7058	ENDIF
7059
7060	CALL MPI_Win_allocate(INT(STORAGE_SIZE(1_iwp)/8nsurf_type_unz_urbannnynnx, &
7061	kind=MPI_ADDRESS_KIND), STORAGE_SIZE(1_iwp)/8, &
7062	minfo, comm2d, gridsurf_rma_p, win_gridsurf, ierr)
7063	IF ( ierr /= 0 ) THEN
7064	WRITE(9,*) 'Error MPI_Win_allocate1:', ierr, &
7065	INT(STORAGE_SIZE(1_iwp)/8nsurf_type_unz_urbannnynnx,kind=MPI_ADDRESS_KIND), &
7066	STORAGE_SIZE(1_iwp)/8, win_gridsurf
7067	FLUSH(9)
7068	ENDIF
7069
7070	CALL MPI_Info_free(minfo, ierr)
7071	IF ( ierr /= 0 ) THEN
7072	WRITE(9,*) 'Error MPI_Info_free1:', ierr
7073	FLUSH(9)
7074	ENDIF
7075
7076	!
7077	!-- On Intel compilers, calling c_f_pointer to transform a C pointer
7078	!-- directly to a multi-dimensional Fotran pointer leads to strange
7079	!-- errors on dimension boundaries. However, transforming to a 1D
7080	!-- pointer and then redirecting a multidimensional pointer to it works
7081	!-- fine.
7082	CALL c_f_pointer(gridsurf_rma_p, gridsurf_rma, (/ nsurf_type_unz_urbannny*nnx /))
7083	gridsurf(0:nsurf_type_u-1, nz_urban_b:nz_urban_t, nys:nyn, nxl:nxr) => &
7084	gridsurf_rma(1:nsurf_type_unz_urbannny*nnx)
7085	#else
7086	ALLOCATE(gridsurf(0:nsurf_type_u-1,nz_urban_b:nz_urban_t,nys:nyn,nxl:nxr) )
7087	#endif
7088	gridsurf(:,:,:,:) = -999
7089	ENDIF
7090
7091	!-- add horizontal surface elements (land and urban surfaces)
7092	!-- TODO: add urban overhanging surfaces (idown_u)
7093	DO i = nxl, nxr
7094	DO j = nys, nyn
7095	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
7096	k = surf_usm_h%k(m)
7097	isurf = isurf + 1
7098	surfl(:,isurf) = (/iup_u,k,j,i,m/)
7099	IF ( rad_angular_discretization ) THEN
7100	gridsurf(iup_u,k,j,i) = isurf
7101	ENDIF
7102	ENDDO
7103
7104	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
7105	k = surf_lsm_h%k(m)
7106	isurf = isurf + 1
7107	surfl(:,isurf) = (/iup_l,k,j,i,m/)
7108	IF ( rad_angular_discretization ) THEN
7109	gridsurf(iup_u,k,j,i) = isurf
7110	ENDIF
7111	ENDDO
7112
7113	ENDDO
7114	ENDDO
7115
7116	!-- add vertical surface elements (land and urban surfaces)
7117	!-- TODO: remove the hard coding of l = 0 to l = idirection
7118	DO i = nxl, nxr
7119	DO j = nys, nyn
7120	l = 0
7121	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
7122	k = surf_usm_v(l)%k(m)
7123	isurf = isurf + 1
7124	surfl(:,isurf) = (/inorth_u,k,j,i,m/)
7125	IF ( rad_angular_discretization ) THEN
7126	gridsurf(inorth_u,k,j,i) = isurf
7127	ENDIF
7128	ENDDO
7129	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
7130	k = surf_lsm_v(l)%k(m)
7131	isurf = isurf + 1
7132	surfl(:,isurf) = (/inorth_l,k,j,i,m/)
7133	IF ( rad_angular_discretization ) THEN
7134	gridsurf(inorth_u,k,j,i) = isurf
7135	ENDIF
7136	ENDDO
7137
7138	l = 1
7139	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
7140	k = surf_usm_v(l)%k(m)
7141	isurf = isurf + 1
7142	surfl(:,isurf) = (/isouth_u,k,j,i,m/)
7143	IF ( rad_angular_discretization ) THEN
7144	gridsurf(isouth_u,k,j,i) = isurf
7145	ENDIF
7146	ENDDO
7147	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
7148	k = surf_lsm_v(l)%k(m)
7149	isurf = isurf + 1
7150	surfl(:,isurf) = (/isouth_l,k,j,i,m/)
7151	IF ( rad_angular_discretization ) THEN
7152	gridsurf(isouth_u,k,j,i) = isurf
7153	ENDIF
7154	ENDDO
7155
7156	l = 2
7157	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
7158	k = surf_usm_v(l)%k(m)
7159	isurf = isurf + 1
7160	surfl(:,isurf) = (/ieast_u,k,j,i,m/)
7161	IF ( rad_angular_discretization ) THEN
7162	gridsurf(ieast_u,k,j,i) = isurf
7163	ENDIF
7164	ENDDO
7165	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
7166	k = surf_lsm_v(l)%k(m)
7167	isurf = isurf + 1
7168	surfl(:,isurf) = (/ieast_l,k,j,i,m/)
7169	IF ( rad_angular_discretization ) THEN
7170	gridsurf(ieast_u,k,j,i) = isurf
7171	ENDIF
7172	ENDDO
7173
7174	l = 3
7175	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
7176	k = surf_usm_v(l)%k(m)
7177	isurf = isurf + 1
7178	surfl(:,isurf) = (/iwest_u,k,j,i,m/)
7179	IF ( rad_angular_discretization ) THEN
7180	gridsurf(iwest_u,k,j,i) = isurf
7181	ENDIF
7182	ENDDO
7183	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
7184	k = surf_lsm_v(l)%k(m)
7185	isurf = isurf + 1
7186	surfl(:,isurf) = (/iwest_l,k,j,i,m/)
7187	IF ( rad_angular_discretization ) THEN
7188	gridsurf(iwest_u,k,j,i) = isurf
7189	ENDIF
7190	ENDDO
7191	ENDDO
7192	ENDDO
7193	!
7194	!-- Add local MRT boxes for specified number of levels
7195	nmrtbl = 0
7196	IF ( mrt_nlevels > 0 ) THEN
7197	DO i = nxl, nxr
7198	DO j = nys, nyn
7199	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
7200	!
7201	!-- Skip roof if requested
7202	IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE
7203	!
7204	!-- Cycle over specified no of levels
7205	nmrtbl = nmrtbl + mrt_nlevels
7206	ENDDO
7207	!
7208	!-- Dtto for LSM
7209	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
7210	nmrtbl = nmrtbl + mrt_nlevels
7211	ENDDO
7212	ENDDO
7213	ENDDO
7214
7215	ALLOCATE( mrtbl(iz:ix,nmrtbl), mrtsky(nmrtbl), mrtskyt(nmrtbl), &
7216	mrtinsw(nmrtbl), mrtinlw(nmrtbl), mrt(nmrtbl) )
7217
7218	imrt = 0
7219	DO i = nxl, nxr
7220	DO j = nys, nyn
7221	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
7222	!
7223	!-- Skip roof if requested
7224	IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE
7225	!
7226	!-- Cycle over specified no of levels
7227	l = surf_usm_h%k(m)
7228	DO k = l, l + mrt_nlevels - 1
7229	imrt = imrt + 1
7230	mrtbl(:,imrt) = (/k,j,i/)
7231	ENDDO
7232	ENDDO
7233	!
7234	!-- Dtto for LSM
7235	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
7236	l = surf_lsm_h%k(m)
7237	DO k = l, l + mrt_nlevels - 1
7238	imrt = imrt + 1
7239	mrtbl(:,imrt) = (/k,j,i/)
7240	ENDDO
7241	ENDDO
7242	ENDDO
7243	ENDDO
7244	ENDIF
7245
7246	!
7247	!-- broadband albedo of the land, roof and wall surface
7248	!-- for domain border and sky set artifically to 1.0
7249	!-- what allows us to calculate heat flux leaving over
7250	!-- side and top borders of the domain
7251	ALLOCATE ( albedo_surf(nsurfl) )
7252	albedo_surf = 1.0_wp
7253	!
7254	!-- Also allocate further array for emissivity with identical order of
7255	!-- surface elements as radiation arrays.
7256	ALLOCATE ( emiss_surf(nsurfl) )
7257
7258
7259	!
7260	!-- global array surf of indices of surfaces and displacement index array surfstart
7261	ALLOCATE(nsurfs(0:numprocs-1))
7262
7263	#if defined( __parallel )
7264	CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr)
7265	IF ( ierr /= 0 ) THEN
7266	WRITE(9,*) 'Error MPI_AllGather1:', ierr, nsurfl, nsurfs
7267	FLUSH(9)
7268	ENDIF
7269
7270	#else
7271	nsurfs(0) = nsurfl
7272	#endif
7273	ALLOCATE(surfstart(0:numprocs))
7274	k = 0
7275	DO i=0,numprocs-1
7276	surfstart(i) = k
7277	k = k+nsurfs(i)
7278	ENDDO
7279	surfstart(numprocs) = k
7280	nsurf = k
7281	!
7282	!-- We allocate the array as linear and then use a two-dimensional pointer
7283	!-- into it, because some MPI implementations crash with 2D-allocated arrays.
7284	ALLOCATE(surf_linear(nidx_surf*nsurf))
7285	surf(1:nidx_surf,1:nsurf) => surf_linear(1:nidx_surf*nsurf)
7286
7287	#if defined( __parallel )
7288	CALL MPI_AllGatherv(surfl_linear, nsurfl*nidx_surf, MPI_INTEGER, &
7289	surf_linear, nsurfs*nidx_surf, &
7290	surfstart(0:numprocs-1)*nidx_surf, MPI_INTEGER, &
7291	comm2d, ierr)
7292	IF ( ierr /= 0 ) THEN
7293	WRITE(9,*) 'Error MPI_AllGatherv4:', ierr, SIZE(surfl_linear), &
7294	nsurflnidx_surf, SIZE(surf_linear), nsurfsnidx_surf, &
7295	surfstart(0:numprocs-1)*nidx_surf
7296	FLUSH(9)
7297	ENDIF
7298	#else
7299	surf = surfl
7300	#endif
7301
7302	!--
7303	!-- allocation of the arrays for direct and diffusion radiation
7304	IF ( debug_output ) CALL debug_message( 'allocation of radiation arrays', 'info' )
7305	!-- rad_sw_in, rad_lw_in are computed in radiation model,
7306	!-- splitting of direct and diffusion part is done
7307	!-- in calc_diffusion_radiation for now
7308
7309	ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) )
7310	ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) )
7311	ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) )
7312	rad_sw_in_dir = 0.0_wp
7313	rad_sw_in_diff = 0.0_wp
7314	rad_lw_in_diff = 0.0_wp
7315
7316	!-- allocate radiation arrays
7317	ALLOCATE( surfins(nsurfl) )
7318	ALLOCATE( surfinl(nsurfl) )
7319	ALLOCATE( surfinsw(nsurfl) )
7320	ALLOCATE( surfinlw(nsurfl) )
7321	ALLOCATE( surfinswdir(nsurfl) )
7322	ALLOCATE( surfinswdif(nsurfl) )
7323	ALLOCATE( surfinlwdif(nsurfl) )
7324	ALLOCATE( surfoutsl(nsurfl) )
7325	ALLOCATE( surfoutll(nsurfl) )
7326	ALLOCATE( surfoutsw(nsurfl) )
7327	ALLOCATE( surfoutlw(nsurfl) )
7328	ALLOCATE( surfouts(nsurf) )
7329	ALLOCATE( surfoutl(nsurf) )
7330	ALLOCATE( surfinlg(nsurf) )
7331	ALLOCATE( skyvf(nsurfl) )
7332	ALLOCATE( skyvft(nsurfl) )
7333	ALLOCATE( surfemitlwl(nsurfl) )
7334
7335	!
7336	!-- In case of average_radiation, aggregated surface albedo and emissivity,
7337	!-- also set initial value for t_rad_urb.
7338	!-- For now set an arbitrary initial value.
7339	IF ( average_radiation ) THEN
7340	albedo_urb = 0.1_wp
7341	emissivity_urb = 0.9_wp
7342	t_rad_urb = pt_surface
7343	ENDIF
7344
7345	END SUBROUTINE radiation_interaction_init
7346
7347	!------------------------------------------------------------------------------!
7348	! Description:
7349	! ------------
7350	!> Calculates shape view factors (SVF), plant sink canopy factors (PCSF),
7351	!> sky-view factors, discretized path for direct solar radiation, MRT factors
7352	!> and other preprocessed data needed for radiation_interaction inside RTM.
7353	!> This subroutine is called only one at the beginning of the simulation.
7354	!> The resulting factors can be stored to files and reused with other
7355	!> simulations utilizing the same surface and plant canopy structure.
7356	!------------------------------------------------------------------------------!
7357	SUBROUTINE radiation_calc_svf
7358
7359	IMPLICIT NONE
7360
7361	INTEGER(iwp) :: i, j, k, d, ip, jp
7362	INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb
7363	INTEGER(iwp) :: sd, td
7364	INTEGER(iwp) :: iaz, izn !< azimuth, zenith counters
7365	INTEGER(iwp) :: naz, nzn !< azimuth, zenith num of steps
7366	REAL(wp) :: az0, zn0 !< starting azimuth/zenith
7367	REAL(wp) :: azs, zns !< azimuth/zenith cycle step
7368	REAL(wp) :: az1, az2 !< relative azimuth of section borders
7369	REAL(wp) :: azmid !< ray (center) azimuth
7370	REAL(wp) :: yxlen !< \|yxdir\|
7371	REAL(wp), DIMENSION(2) :: yxdir !< y,x unit vector of ray direction (in grid units)
7372	REAL(wp), DIMENSION(:), ALLOCATABLE :: zdirs !< directions in z (tangent of elevation)
7373	REAL(wp), DIMENSION(:), ALLOCATABLE :: zcent !< zenith angle centers
7374	REAL(wp), DIMENSION(:), ALLOCATABLE :: zbdry !< zenith angle boundaries
7375	REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac !< view factor fractions for individual rays
7376	REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac0 !< dtto (original values)
7377	REAL(wp), DIMENSION(:), ALLOCATABLE :: ztransp !< array of transparency in z steps
7378	INTEGER(iwp) :: lowest_free_ray !< index into zdirs
7379	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: itarget !< face indices of detected obstacles
7380	INTEGER(iwp) :: itarg0, itarg1
7381
7382	INTEGER(iwp) :: udim
7383	REAL(wp), DIMENSION(:), ALLOCATABLE,TARGET:: csflt_l, pcsflt_l
7384	REAL(wp), DIMENSION(:,:), POINTER :: csflt, pcsflt
7385	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: kcsflt_l,kpcsflt_l
7386	INTEGER(iwp), DIMENSION(:,:), POINTER :: kcsflt,kpcsflt
7387	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt
7388	REAL(wp), DIMENSION(3) :: uv
7389	LOGICAL :: visible
7390	REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target
7391	REAL(wp) :: difvf !< differential view factor
7392	REAL(wp) :: transparency, rirrf, sqdist, svfsum
7393	INTEGER(iwp) :: isurflt, isurfs, isurflt_prev
7394	INTEGER(idp) :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts
7395	INTEGER(iwp) :: max_track_len !< maximum 2d track length
7396	#if defined( __parallel )
7397	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: nzterrl_l
7398	INTEGER(iwp), DIMENSION(:,:), POINTER :: nzterrl
7399	INTEGER(iwp) :: minfo
7400	REAL(wp), DIMENSION(:), POINTER, SAVE :: lad_s_rma !< fortran 1D pointer
7401	TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer
7402	INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma
7403	#endif
7404	!
7405	INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts
7406
7407
7408	!-- calculation of the SVF
7409	CALL location_message( 'calculating view factors for radiation interaction', 'start' )
7410
7411	!-- initialize variables and temporary arrays for calculation of svf and csf
7412	nsvfl = 0
7413	ncsfl = 0
7414	nsvfla = gasize
7415	msvf = 1
7416	ALLOCATE( asvf1(nsvfla) )
7417	asvf => asvf1
7418	IF ( plant_canopy ) THEN
7419	ncsfla = gasize
7420	mcsf = 1
7421	ALLOCATE( acsf1(ncsfla) )
7422	acsf => acsf1
7423	ENDIF
7424	nmrtf = 0
7425	IF ( mrt_nlevels > 0 ) THEN
7426	nmrtfa = gasize
7427	mmrtf = 1
7428	ALLOCATE ( amrtf1(nmrtfa) )
7429	amrtf => amrtf1
7430	ENDIF
7431	ray_skip_maxdist = 0
7432	ray_skip_minval = 0
7433
7434	!-- initialize temporary terrain and plant canopy height arrays (global 2D array!)
7435	ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) )
7436	#if defined( __parallel )
7437	!ALLOCATE( nzterrl(nys:nyn,nxl:nxr) )
7438	ALLOCATE( nzterrl_l((nyn-nys+1)*(nxr-nxl+1)) )
7439	nzterrl(nys:nyn,nxl:nxr) => nzterrl_l(1:(nyn-nys+1)*(nxr-nxl+1))
7440	nzterrl = topo_top_ind(nys:nyn,nxl:nxr,0)
7441	CALL MPI_AllGather( nzterrl_l, nnx*nny, MPI_INTEGER, &
7442	nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr )
7443	IF ( ierr /= 0 ) THEN
7444	WRITE(9,) 'Error MPI_AllGather1:', ierr, SIZE(nzterrl_l), nnxnny, &
7445	SIZE(nzterr), nnx*nny
7446	FLUSH(9)
7447	ENDIF
7448	DEALLOCATE(nzterrl_l)
7449	#else
7450	nzterr = RESHAPE( topo_top_ind(nys:nyn,nxl:nxr,0), (/(nx+1)*(ny+1)/) )
7451	#endif
7452	IF ( plant_canopy ) THEN
7453	ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) )
7454	maxboxesg = nx + ny + nz_plant + 1
7455	max_track_len = nx + ny + 1
7456	!-- temporary arrays storing values for csf calculation during raytracing
7457	ALLOCATE( boxes(3, maxboxesg) )
7458	ALLOCATE( crlens(maxboxesg) )
7459
7460	#if defined( __parallel )
7461	CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, &
7462	plantt, nnx*nny, MPI_INTEGER, comm2d, ierr )
7463	IF ( ierr /= 0 ) THEN
7464	WRITE(9,) 'Error MPI_AllGather2:', ierr, SIZE(pct), nnxnny, &
7465	SIZE(plantt), nnx*nny
7466	FLUSH(9)
7467	ENDIF
7468
7469	!-- temporary arrays storing values for csf calculation during raytracing
7470	ALLOCATE( lad_ip(maxboxesg) )
7471	ALLOCATE( lad_disp(maxboxesg) )
7472
7473	IF ( raytrace_mpi_rma ) THEN
7474	ALLOCATE( lad_s_ray(maxboxesg) )
7475
7476	! set conditions for RMA communication
7477	CALL MPI_Info_create(minfo, ierr)
7478	IF ( ierr /= 0 ) THEN
7479	WRITE(9,*) 'Error MPI_Info_create2:', ierr
7480	FLUSH(9)
7481	ENDIF
7482	CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
7483	IF ( ierr /= 0 ) THEN
7484	WRITE(9,*) 'Error MPI_Info_set5:', ierr
7485	FLUSH(9)
7486	ENDIF
7487	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
7488	IF ( ierr /= 0 ) THEN
7489	WRITE(9,*) 'Error MPI_Info_set6:', ierr
7490	FLUSH(9)
7491	ENDIF
7492	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
7493	IF ( ierr /= 0 ) THEN
7494	WRITE(9,*) 'Error MPI_Info_set7:', ierr
7495	FLUSH(9)
7496	ENDIF
7497	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
7498	IF ( ierr /= 0 ) THEN
7499	WRITE(9,*) 'Error MPI_Info_set8:', ierr
7500	FLUSH(9)
7501	ENDIF
7502
7503	!-- Allocate and initialize the MPI RMA window
7504	!-- must be in accordance with allocation of lad_s in plant_canopy_model
7505	!-- optimization of memory should be done
7506	!-- Argument X of function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now
7507	size_lad_rma = STORAGE_SIZE(1.0_wp)/8nnxnny*nz_plant
7508	CALL MPI_Win_allocate(size_lad_rma, STORAGE_SIZE(1.0_wp)/8, minfo, comm2d, &
7509	lad_s_rma_p, win_lad, ierr)
7510	IF ( ierr /= 0 ) THEN
7511	WRITE(9,*) 'Error MPI_Win_allocate2:', ierr, size_lad_rma, &
7512	STORAGE_SIZE(1.0_wp)/8, win_lad
7513	FLUSH(9)
7514	ENDIF
7515	CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nz_plantnnynnx /))
7516	sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr) => lad_s_rma(1:nz_plantnnynnx)
7517	ELSE
7518	ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
7519	ENDIF
7520	#else
7521	plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) )
7522	ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
7523	#endif
7524	plantt_max = MAXVAL(plantt)
7525	ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nz_urban_b:plantt_max, max_track_len), &
7526	rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nz_urban_b+2) )
7527
7528	sub_lad(:,:,:) = 0._wp
7529	DO i = nxl, nxr
7530	DO j = nys, nyn
7531	k = topo_top_ind(j,i,0)
7532
7533	sub_lad(k:nz_plant_t, j, i) = lad_s(0:nz_plant_t-k, j, i)
7534	ENDDO
7535	ENDDO
7536
7537	#if defined( __parallel )
7538	IF ( raytrace_mpi_rma ) THEN
7539	CALL MPI_Info_free(minfo, ierr)
7540	IF ( ierr /= 0 ) THEN
7541	WRITE(9,*) 'Error MPI_Info_free2:', ierr
7542	FLUSH(9)
7543	ENDIF
7544	CALL MPI_Win_lock_all(0, win_lad, ierr)
7545	IF ( ierr /= 0 ) THEN
7546	WRITE(9,*) 'Error MPI_Win_lock_all1:', ierr, win_lad
7547	FLUSH(9)
7548	ENDIF
7549
7550	ELSE
7551	ALLOCATE( sub_lad_g(0:(nx+1)(ny+1)nz_plant-1) )
7552	CALL MPI_AllGather( sub_lad, nnxnnynz_plant, MPI_REAL, &
7553	sub_lad_g, nnxnnynz_plant, MPI_REAL, comm2d, ierr )
7554	IF ( ierr /= 0 ) THEN
7555	WRITE(9,*) 'Error MPI_AllGather3:', ierr, SIZE(sub_lad), &
7556	nnxnnynz_plant, SIZE(sub_lad_g), nnxnnynz_plant
7557	FLUSH(9)
7558	ENDIF
7559	ENDIF
7560	#endif
7561	ENDIF
7562
7563	!-- prepare the MPI_Win for collecting the surface indices
7564	!-- from the reverse index arrays gridsurf from processors of target surfaces
7565	#if defined( __parallel )
7566	IF ( rad_angular_discretization ) THEN
7567	!
7568	!-- raytrace_mpi_rma is asserted
7569	CALL MPI_Win_lock_all(0, win_gridsurf, ierr)
7570	IF ( ierr /= 0 ) THEN
7571	WRITE(9,*) 'Error MPI_Win_lock_all2:', ierr, win_gridsurf
7572	FLUSH(9)
7573	ENDIF
7574	ENDIF
7575	#endif
7576
7577
7578	!--Directions opposite to face normals are not even calculated,
7579	!--they must be preset to 0
7580	!--
7581	dsitrans(:,:) = 0._wp
7582
7583	DO isurflt = 1, nsurfl
7584	!-- determine face centers
7585	td = surfl(id, isurflt)
7586	ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), &
7587	REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), &
7588	REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /)
7589
7590	!--Calculate sky view factor and raytrace DSI paths
7591	skyvf(isurflt) = 0._wp
7592	skyvft(isurflt) = 0._wp
7593
7594	!--Select a proper half-sphere for 2D raytracing
7595	SELECT CASE ( td )
7596	CASE ( iup_u, iup_l )
7597	az0 = 0._wp
7598	naz = raytrace_discrete_azims
7599	azs = 2._wp * pi / REAL(naz, wp)
7600	zn0 = 0._wp
7601	nzn = raytrace_discrete_elevs / 2
7602	zns = pi / 2._wp / REAL(nzn, wp)
7603	CASE ( isouth_u, isouth_l )
7604	az0 = pi / 2._wp
7605	naz = raytrace_discrete_azims / 2
7606	azs = pi / REAL(naz, wp)
7607	zn0 = 0._wp
7608	nzn = raytrace_discrete_elevs
7609	zns = pi / REAL(nzn, wp)
7610	CASE ( inorth_u, inorth_l )
7611	az0 = - pi / 2._wp
7612	naz = raytrace_discrete_azims / 2
7613	azs = pi / REAL(naz, wp)
7614	zn0 = 0._wp
7615	nzn = raytrace_discrete_elevs
7616	zns = pi / REAL(nzn, wp)
7617	CASE ( iwest_u, iwest_l )
7618	az0 = pi
7619	naz = raytrace_discrete_azims / 2
7620	azs = pi / REAL(naz, wp)
7621	zn0 = 0._wp
7622	nzn = raytrace_discrete_elevs
7623	zns = pi / REAL(nzn, wp)
7624	CASE ( ieast_u, ieast_l )
7625	az0 = 0._wp
7626	naz = raytrace_discrete_azims / 2
7627	azs = pi / REAL(naz, wp)
7628	zn0 = 0._wp
7629	nzn = raytrace_discrete_elevs
7630	zns = pi / REAL(nzn, wp)
7631	CASE DEFAULT
7632	WRITE(message_string, *) 'ERROR: the surface type ', td, &
7633	' is not supported for calculating',&
7634	' SVF'
7635	CALL message( 'radiation_calc_svf', 'PA0488', 1, 2, 0, 6, 0 )
7636	END SELECT
7637
7638	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), &
7639	ztransp(1:nznnaz), itarget(1:nznnaz) ) !FIXME allocate itarget only
7640	!in case of rad_angular_discretization
7641
7642	itarg0 = 1
7643	itarg1 = nzn
7644	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7645	zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7646	IF ( td == iup_u .OR. td == iup_l ) THEN
7647	vffrac(1:nzn) = (COS(2 * zbdry(0:nzn-1)) - COS(2 * zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7648	!
7649	!-- For horizontal target, vf fractions are constant per azimuth
7650	DO iaz = 1, naz-1
7651	vffrac(iaznzn+1:(iaz+1)nzn) = vffrac(1:nzn)
7652	ENDDO
7653	!-- sum of whole vffrac equals 1, verified
7654	ENDIF
7655	!
7656	!-- Calculate sky-view factor and direct solar visibility using 2D raytracing
7657	DO iaz = 1, naz
7658	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7659	IF ( td /= iup_u .AND. td /= iup_l ) THEN
7660	az2 = REAL(iaz, wp) * azs - pi/2._wp
7661	az1 = az2 - azs
7662	!TODO precalculate after 1st line
7663	vffrac(itarg0:itarg1) = (SIN(az2) - SIN(az1)) &
7664	* (zbdry(1:nzn) - zbdry(0:nzn-1) &
7665	+ SIN(zbdry(0:nzn-1))*COS(zbdry(0:nzn-1)) &
7666	- SIN(zbdry(1:nzn))*COS(zbdry(1:nzn))) &
7667	/ (2._wp * pi)
7668	!-- sum of whole vffrac equals 1, verified
7669	ENDIF
7670	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7671	yxlen = SQRT(SUM(yxdir(:)**2))
7672	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7673	yxdir(:) = yxdir(:) / yxlen
7674
7675	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7676	surfstart(myid) + isurflt, facearea(td), &
7677	vffrac(itarg0:itarg1), .TRUE., .TRUE., &
7678	.FALSE., lowest_free_ray, &
7679	ztransp(itarg0:itarg1), &
7680	itarget(itarg0:itarg1))
7681
7682	skyvf(isurflt) = skyvf(isurflt) + &
7683	SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7684	skyvft(isurflt) = skyvft(isurflt) + &
7685	SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7686	* vffrac(itarg0:itarg0+lowest_free_ray-1))
7687
7688	!-- Save direct solar transparency
7689	j = MODULO(NINT(azmid/ &
7690	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7691	raytrace_discrete_azims)
7692
7693	DO k = 1, raytrace_discrete_elevs/2
7694	i = dsidir_rev(k-1, j)
7695	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7696	dsitrans(isurflt, i) = ztransp(itarg0+k-1)
7697	ENDDO
7698
7699	!
7700	!-- Advance itarget indices
7701	itarg0 = itarg1 + 1
7702	itarg1 = itarg1 + nzn
7703	ENDDO
7704
7705	IF ( rad_angular_discretization ) THEN
7706	!-- sort itarget by face id
7707	CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7708	!
7709	!-- For aggregation, we need fractions multiplied by transmissivities
7710	ztransp(:) = vffrac(:) * ztransp(:)
7711	!
7712	!-- find the first valid position
7713	itarg0 = 1
7714	DO WHILE ( itarg0 <= nzn*naz )
7715	IF ( itarget(itarg0) /= -1 ) EXIT
7716	itarg0 = itarg0 + 1
7717	ENDDO
7718
7719	DO i = itarg0, nzn*naz
7720	!
7721	!-- For duplicate values, only sum up vf fraction value
7722	IF ( i < nzn*naz ) THEN
7723	IF ( itarget(i+1) == itarget(i) ) THEN
7724	vffrac(i+1) = vffrac(i+1) + vffrac(i)
7725	ztransp(i+1) = ztransp(i+1) + ztransp(i)
7726	CYCLE
7727	ENDIF
7728	ENDIF
7729	!
7730	!-- write to the svf array
7731	nsvfl = nsvfl + 1
7732	!-- check dimmension of asvf array and enlarge it if needed
7733	IF ( nsvfla < nsvfl ) THEN
7734	k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7735	IF ( msvf == 0 ) THEN
7736	msvf = 1
7737	ALLOCATE( asvf1(k) )
7738	asvf => asvf1
7739	asvf1(1:nsvfla) = asvf2
7740	DEALLOCATE( asvf2 )
7741	ELSE
7742	msvf = 0
7743	ALLOCATE( asvf2(k) )
7744	asvf => asvf2
7745	asvf2(1:nsvfla) = asvf1
7746	DEALLOCATE( asvf1 )
7747	ENDIF
7748
7749	IF ( debug_output ) THEN
7750	WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7751	CALL debug_message( debug_string, 'info' )
7752	ENDIF
7753
7754	nsvfla = k
7755	ENDIF
7756	!-- write svf values into the array
7757	asvf(nsvfl)%isurflt = isurflt
7758	asvf(nsvfl)%isurfs = itarget(i)
7759	asvf(nsvfl)%rsvf = vffrac(i)
7760	asvf(nsvfl)%rtransp = ztransp(i) / vffrac(i)
7761	END DO
7762
7763	ENDIF ! rad_angular_discretization
7764
7765	DEALLOCATE ( zdirs, zcent, zbdry, vffrac, ztransp, itarget ) !FIXME itarget shall be allocated only
7766	!in case of rad_angular_discretization
7767	!
7768	!-- Following calculations only required for surface_reflections
7769	IF ( surface_reflections .AND. .NOT. rad_angular_discretization ) THEN
7770
7771	DO isurfs = 1, nsurf
7772	IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), &
7773	surfl(iz, isurflt), surfl(id, isurflt), &
7774	surf(ix, isurfs), surf(iy, isurfs), &
7775	surf(iz, isurfs), surf(id, isurfs)) ) THEN
7776	CYCLE
7777	ENDIF
7778
7779	sd = surf(id, isurfs)
7780	sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), &
7781	REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), &
7782	REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /)
7783
7784	!-- unit vector source -> target
7785	uv = (/ (ta(1)-sa(1))dz(1), (ta(2)-sa(2))dy, (ta(3)-sa(3))*dx /)
7786	sqdist = SUM(uv(:)**2)
7787	uv = uv / SQRT(sqdist)
7788
7789	!-- reject raytracing above max distance
7790	IF ( SQRT(sqdist) > max_raytracing_dist ) THEN
7791	ray_skip_maxdist = ray_skip_maxdist + 1
7792	CYCLE
7793	ENDIF
7794
7795	difvf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction
7796	* dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction
7797	/ (pi * sqdist) ! square of distance between centers
7798	!
7799	!-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area
7800	rirrf = difvf * facearea(sd)
7801
7802	!-- reject raytracing for potentially too small view factor values
7803	IF ( rirrf < min_irrf_value ) THEN
7804	ray_skip_minval = ray_skip_minval + 1
7805	CYCLE
7806	ENDIF
7807
7808	!-- raytrace + process plant canopy sinks within
7809	CALL raytrace(sa, ta, isurfs, difvf, facearea(td), .TRUE., &
7810	visible, transparency)
7811
7812	IF ( .NOT. visible ) CYCLE
7813	! rsvf = rirrf * transparency
7814
7815	!-- write to the svf array
7816	nsvfl = nsvfl + 1
7817	!-- check dimmension of asvf array and enlarge it if needed
7818	IF ( nsvfla < nsvfl ) THEN
7819	k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7820	IF ( msvf == 0 ) THEN
7821	msvf = 1
7822	ALLOCATE( asvf1(k) )
7823	asvf => asvf1
7824	asvf1(1:nsvfla) = asvf2
7825	DEALLOCATE( asvf2 )
7826	ELSE
7827	msvf = 0
7828	ALLOCATE( asvf2(k) )
7829	asvf => asvf2
7830	asvf2(1:nsvfla) = asvf1
7831	DEALLOCATE( asvf1 )
7832	ENDIF
7833
7834	IF ( debug_output ) THEN
7835	WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7836	CALL debug_message( debug_string, 'info' )
7837	ENDIF
7838
7839	nsvfla = k
7840	ENDIF
7841	!-- write svf values into the array
7842	asvf(nsvfl)%isurflt = isurflt
7843	asvf(nsvfl)%isurfs = isurfs
7844	asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency
7845	asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor
7846	ENDDO
7847	ENDIF
7848	ENDDO
7849
7850	!--
7851	!-- Raytrace to canopy boxes to fill dsitransc TODO optimize
7852	dsitransc(:,:) = 0._wp
7853	az0 = 0._wp
7854	naz = raytrace_discrete_azims
7855	azs = 2._wp * pi / REAL(naz, wp)
7856	zn0 = 0._wp
7857	nzn = raytrace_discrete_elevs / 2
7858	zns = pi / 2._wp / REAL(nzn, wp)
7859	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), vffrac(1:nzn), ztransp(1:nzn), &
7860	itarget(1:nzn) )
7861	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7862	vffrac(:) = 0._wp
7863
7864	DO ipcgb = 1, npcbl
7865	ta = (/ REAL(pcbl(iz, ipcgb), wp), &
7866	REAL(pcbl(iy, ipcgb), wp), &
7867	REAL(pcbl(ix, ipcgb), wp) /)
7868	!-- Calculate direct solar visibility using 2D raytracing
7869	DO iaz = 1, naz
7870	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7871	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7872	yxlen = SQRT(SUM(yxdir(:)**2))
7873	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7874	yxdir(:) = yxdir(:) / yxlen
7875	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7876	-999, -999._wp, vffrac, .FALSE., .FALSE., .TRUE., &
7877	lowest_free_ray, ztransp, itarget)
7878
7879	!-- Save direct solar transparency
7880	j = MODULO(NINT(azmid/ &
7881	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7882	raytrace_discrete_azims)
7883	DO k = 1, raytrace_discrete_elevs/2
7884	i = dsidir_rev(k-1, j)
7885	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7886	dsitransc(ipcgb, i) = ztransp(k)
7887	ENDDO
7888	ENDDO
7889	ENDDO
7890	DEALLOCATE ( zdirs, zcent, vffrac, ztransp, itarget )
7891	!--
7892	!-- Raytrace to MRT boxes
7893	IF ( nmrtbl > 0 ) THEN
7894	mrtdsit(:,:) = 0._wp
7895	mrtsky(:) = 0._wp
7896	mrtskyt(:) = 0._wp
7897	az0 = 0._wp
7898	naz = raytrace_discrete_azims
7899	azs = 2._wp * pi / REAL(naz, wp)
7900	zn0 = 0._wp
7901	nzn = raytrace_discrete_elevs
7902	zns = pi / REAL(nzn, wp)
7903	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), vffrac0(1:nzn), &
7904	ztransp(1:nznnaz), itarget(1:nznnaz) ) !FIXME allocate itarget only
7905	!in case of rad_angular_discretization
7906
7907	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7908	zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7909	vffrac0(:) = (COS(zbdry(0:nzn-1)) - COS(zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7910	!
7911	!-- Modify direction weights to simulate human body (lower weight for
7912	!-- irradiance from zenith, higher from sides) depending on selection.
7913	!-- For mrt_geom=0, no weighting is done (simulates spherical globe
7914	!-- thermometer).
7915	SELECT CASE ( mrt_geom )
7916
7917	CASE ( 1 )
7918	vffrac0(:) = vffrac0(:) * MAX(0._wp, SIN(zcent(:))*mrt_geom_params(2) &
7919	+ COS(zcent(:))*mrt_geom_params(1))
7920	vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp))
7921
7922	CASE ( 2 )
7923	vffrac0(:) = vffrac0(:) &
7924	* SQRT( ( mrt_geom_params(1) * COS(zcent(:)) ) ** 2 &
7925	+ ( mrt_geom_params(2) * SIN(zcent(:)) ) ** 2 )
7926	vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp))
7927
7928	END SELECT
7929
7930	DO imrt = 1, nmrtbl
7931	ta = (/ REAL(mrtbl(iz, imrt), wp), &
7932	REAL(mrtbl(iy, imrt), wp), &
7933	REAL(mrtbl(ix, imrt), wp) /)
7934	!
7935	!-- vf fractions are constant per azimuth
7936	DO iaz = 0, naz-1
7937	vffrac(iaznzn+1:(iaz+1)nzn) = vffrac0(:)
7938	ENDDO
7939	!-- sum of whole vffrac equals 1, verified
7940	itarg0 = 1
7941	itarg1 = nzn
7942	!
7943	!-- Calculate sky-view factor and direct solar visibility using 2D raytracing
7944	DO iaz = 1, naz
7945	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7946	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7947	yxlen = SQRT(SUM(yxdir(:)**2))
7948	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7949	yxdir(:) = yxdir(:) / yxlen
7950
7951	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7952	-999, -999._wp, vffrac(itarg0:itarg1), .TRUE., &
7953	.FALSE., .TRUE., lowest_free_ray, &
7954	ztransp(itarg0:itarg1), &
7955	itarget(itarg0:itarg1))
7956
7957	!-- Sky view factors for MRT
7958	mrtsky(imrt) = mrtsky(imrt) + &
7959	SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7960	mrtskyt(imrt) = mrtskyt(imrt) + &
7961	SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7962	* vffrac(itarg0:itarg0+lowest_free_ray-1))
7963	!-- Direct solar transparency for MRT
7964	j = MODULO(NINT(azmid/ &
7965	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7966	raytrace_discrete_azims)
7967	DO k = 1, raytrace_discrete_elevs/2
7968	i = dsidir_rev(k-1, j)
7969	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7970	mrtdsit(imrt, i) = ztransp(itarg0+k-1)
7971	ENDDO
7972	!
7973	!-- Advance itarget indices
7974	itarg0 = itarg1 + 1
7975	itarg1 = itarg1 + nzn
7976	ENDDO
7977
7978	!-- sort itarget by face id
7979	CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7980	!
7981	!-- find the first valid position
7982	itarg0 = 1
7983	DO WHILE ( itarg0 <= nzn*naz )
7984	IF ( itarget(itarg0) /= -1 ) EXIT
7985	itarg0 = itarg0 + 1
7986	ENDDO
7987
7988	DO i = itarg0, nzn*naz
7989	!
7990	!-- For duplicate values, only sum up vf fraction value
7991	IF ( i < nzn*naz ) THEN
7992	IF ( itarget(i+1) == itarget(i) ) THEN
7993	vffrac(i+1) = vffrac(i+1) + vffrac(i)
7994	CYCLE
7995	ENDIF
7996	ENDIF
7997	!
7998	!-- write to the mrtf array
7999	nmrtf = nmrtf + 1
8000	!-- check dimmension of mrtf array and enlarge it if needed
8001	IF ( nmrtfa < nmrtf ) THEN
8002	k = CEILING(REAL(nmrtfa, kind=wp) * grow_factor)
8003	IF ( mmrtf == 0 ) THEN
8004	mmrtf = 1
8005	ALLOCATE( amrtf1(k) )
8006	amrtf => amrtf1
8007	amrtf1(1:nmrtfa) = amrtf2
8008	DEALLOCATE( amrtf2 )
8009	ELSE
8010	mmrtf = 0
8011	ALLOCATE( amrtf2(k) )
8012	amrtf => amrtf2
8013	amrtf2(1:nmrtfa) = amrtf1
8014	DEALLOCATE( amrtf1 )
8015	ENDIF
8016
8017	IF ( debug_output ) THEN
8018	WRITE( debug_string, '(A,3I12)' ) 'Grow amrtf:', nmrtf, nmrtfa, k
8019	CALL debug_message( debug_string, 'info' )
8020	ENDIF
8021
8022	nmrtfa = k
8023	ENDIF
8024	!-- write mrtf values into the array
8025	amrtf(nmrtf)%isurflt = imrt
8026	amrtf(nmrtf)%isurfs = itarget(i)
8027	amrtf(nmrtf)%rsvf = vffrac(i)
8028	amrtf(nmrtf)%rtransp = ztransp(i)
8029	ENDDO ! itarg
8030
8031	ENDDO ! imrt
8032	DEALLOCATE ( zdirs, zcent, zbdry, vffrac, vffrac0, ztransp, itarget )
8033	!
8034	!-- Move MRT factors to final arrays
8035	ALLOCATE ( mrtf(nmrtf), mrtft(nmrtf), mrtfsurf(2,nmrtf) )
8036	DO imrtf = 1, nmrtf
8037	mrtf(imrtf) = amrtf(imrtf)%rsvf
8038	mrtft(imrtf) = amrtf(imrtf)%rsvf * amrtf(imrtf)%rtransp
8039	mrtfsurf(:,imrtf) = (/amrtf(imrtf)%isurflt, amrtf(imrtf)%isurfs /)
8040	ENDDO
8041	IF ( ALLOCATED(amrtf1) ) DEALLOCATE( amrtf1 )
8042	IF ( ALLOCATED(amrtf2) ) DEALLOCATE( amrtf2 )
8043	ENDIF ! nmrtbl > 0
8044
8045	IF ( rad_angular_discretization ) THEN
8046	#if defined( __parallel )
8047	!-- finalize MPI_RMA communication established to get global index of the surface from grid indices
8048	!-- flush all MPI window pending requests
8049	CALL MPI_Win_flush_all(win_gridsurf, ierr)
8050	IF ( ierr /= 0 ) THEN
8051	WRITE(9,*) 'Error MPI_Win_flush_all1:', ierr, win_gridsurf
8052	FLUSH(9)
8053	ENDIF
8054	!-- unlock MPI window
8055	CALL MPI_Win_unlock_all(win_gridsurf, ierr)
8056	IF ( ierr /= 0 ) THEN
8057	WRITE(9,*) 'Error MPI_Win_unlock_all1:', ierr, win_gridsurf
8058	FLUSH(9)
8059	ENDIF
8060	!-- free MPI window
8061	CALL MPI_Win_free(win_gridsurf, ierr)
8062	IF ( ierr /= 0 ) THEN
8063	WRITE(9,*) 'Error MPI_Win_free1:', ierr, win_gridsurf
8064	FLUSH(9)
8065	ENDIF
8066	#else
8067	DEALLOCATE ( gridsurf )
8068	#endif
8069	ENDIF
8070
8071	IF ( debug_output ) CALL debug_message( 'waiting for completion of SVF and CSF calculation in all processes', 'info' )
8072
8073	!-- deallocate temporary global arrays
8074	DEALLOCATE(nzterr)
8075
8076	IF ( plant_canopy ) THEN
8077	!-- finalize mpi_rma communication and deallocate temporary arrays
8078	#if defined( __parallel )
8079	IF ( raytrace_mpi_rma ) THEN
8080	CALL MPI_Win_flush_all(win_lad, ierr)
8081	IF ( ierr /= 0 ) THEN
8082	WRITE(9,*) 'Error MPI_Win_flush_all2:', ierr, win_lad
8083	FLUSH(9)
8084	ENDIF
8085	!-- unlock MPI window
8086	CALL MPI_Win_unlock_all(win_lad, ierr)
8087	IF ( ierr /= 0 ) THEN
8088	WRITE(9,*) 'Error MPI_Win_unlock_all2:', ierr, win_lad
8089	FLUSH(9)
8090	ENDIF
8091	!-- free MPI window
8092	CALL MPI_Win_free(win_lad, ierr)
8093	IF ( ierr /= 0 ) THEN
8094	WRITE(9,*) 'Error MPI_Win_free2:', ierr, win_lad
8095	FLUSH(9)
8096	ENDIF
8097	!-- deallocate temporary arrays storing values for csf calculation during raytracing
8098	DEALLOCATE( lad_s_ray )
8099	!-- sub_lad is the pointer to lad_s_rma in case of raytrace_mpi_rma
8100	!-- and must not be deallocated here
8101	ELSE
8102	DEALLOCATE(sub_lad)
8103	DEALLOCATE(sub_lad_g)
8104	ENDIF
8105	#else
8106	DEALLOCATE(sub_lad)
8107	#endif
8108	DEALLOCATE( boxes )
8109	DEALLOCATE( crlens )
8110	DEALLOCATE( plantt )
8111	DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist )
8112	ENDIF
8113
8114	IF ( debug_output ) CALL debug_message( 'calculation of the complete SVF array', 'info' )
8115
8116	IF ( rad_angular_discretization ) THEN
8117	IF ( debug_output ) THEN
8118	WRITE( debug_string, '("Load ",I0," SVFs from the structure array to plain arrays")' ) nsvfl
8119	CALL debug_message( debug_string, 'info' )
8120	ENDIF
8121	ALLOCATE( svf(ndsvf,nsvfl) )
8122	ALLOCATE( svfsurf(idsvf,nsvfl) )
8123
8124	DO isvf = 1, nsvfl
8125	svf(:, isvf) = (/ asvf(isvf)%rsvf, asvf(isvf)%rtransp /)
8126	svfsurf(:, isvf) = (/ asvf(isvf)%isurflt, asvf(isvf)%isurfs /)
8127	ENDDO
8128	ELSE
8129	IF ( debug_output ) CALL debug_message( 'Start SVF sort', 'info' )
8130	!-- sort svf ( a version of quicksort )
8131	CALL quicksort_svf(asvf,1,nsvfl)
8132
8133	!< load svf from the structure array to plain arrays
8134	IF ( debug_output ) THEN
8135	WRITE( debug_string, '("Load ",I0," SVFs from the structure array to plain arrays")' ) nsvfl
8136	CALL debug_message( debug_string, 'info' )
8137	ENDIF
8138	ALLOCATE( svf(ndsvf,nsvfl) )
8139	ALLOCATE( svfsurf(idsvf,nsvfl) )
8140	svfnorm_counts(:) = 0._wp
8141	isurflt_prev = -1
8142	ksvf = 1
8143	svfsum = 0._wp
8144	DO isvf = 1, nsvfl
8145	!-- normalize svf per target face
8146	IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN
8147	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
8148	!< update histogram of logged svf normalization values
8149	i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
8150	svfnorm_counts(i) = svfnorm_counts(i) + 1
8151
8152	svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * (1._wp-skyvf(isurflt_prev))
8153	ENDIF
8154	isurflt_prev = asvf(ksvf)%isurflt
8155	isvf_surflt = isvf
8156	svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
8157	ELSE
8158	svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
8159	ENDIF
8160
8161	svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /)
8162	svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /)
8163
8164	!-- next element
8165	ksvf = ksvf + 1
8166	ENDDO
8167
8168	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
8169	i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
8170	svfnorm_counts(i) = svfnorm_counts(i) + 1
8171
8172	svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * (1._wp-skyvf(isurflt_prev))
8173	ENDIF
8174	WRITE(9, *) 'SVF normalization histogram:', svfnorm_counts, &
8175	'on thresholds:', svfnorm_report_thresh(1:svfnorm_report_num), '(val < thresh <= val)'
8176	!TODO we should be able to deallocate skyvf, from now on we only need skyvft
8177	ENDIF ! rad_angular_discretization
8178
8179	!-- deallocate temporary asvf array
8180	!-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target
8181	!-- via pointing pointer - we need to test original targets
8182	IF ( ALLOCATED(asvf1) ) THEN
8183	DEALLOCATE(asvf1)
8184	ENDIF
8185	IF ( ALLOCATED(asvf2) ) THEN
8186	DEALLOCATE(asvf2)
8187	ENDIF
8188
8189	npcsfl = 0
8190	IF ( plant_canopy ) THEN
8191
8192	IF ( debug_output ) CALL debug_message( 'Calculation of the complete CSF array', 'info' )
8193	!-- sort and merge csf for the last time, keeping the array size to minimum
8194	CALL merge_and_grow_csf(-1)
8195
8196	!-- aggregate csb among processors
8197	!-- allocate necessary arrays
8198	udim = max(ncsfl,1)
8199	ALLOCATE( csflt_l(ndcsf*udim) )
8200	csflt(1:ndcsf,1:udim) => csflt_l(1:ndcsf*udim)
8201	ALLOCATE( kcsflt_l(kdcsf*udim) )
8202	kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim)
8203	ALLOCATE( icsflt(0:numprocs-1) )
8204	ALLOCATE( dcsflt(0:numprocs-1) )
8205	ALLOCATE( ipcsflt(0:numprocs-1) )
8206	ALLOCATE( dpcsflt(0:numprocs-1) )
8207
8208	!-- fill out arrays of csf values and
8209	!-- arrays of number of elements and displacements
8210	!-- for particular precessors
8211	icsflt = 0
8212	dcsflt = 0
8213	ip = -1
8214	j = -1
8215	d = 0
8216	DO kcsf = 1, ncsfl
8217	j = j+1
8218	IF ( acsf(kcsf)%ip /= ip ) THEN
8219	!-- new block of the processor
8220	!-- number of elements of previous block
8221	IF ( ip>=0) icsflt(ip) = j
8222	d = d+j
8223	!-- blank blocks
8224	DO jp = ip+1, acsf(kcsf)%ip-1
8225	!-- number of elements is zero, displacement is equal to previous
8226	icsflt(jp) = 0
8227	dcsflt(jp) = d
8228	ENDDO
8229	!-- the actual block
8230	ip = acsf(kcsf)%ip
8231	dcsflt(ip) = d
8232	j = 0
8233	ENDIF
8234	csflt(1,kcsf) = acsf(kcsf)%rcvf
8235	!-- fill out integer values of itz,ity,itx,isurfs
8236	kcsflt(1,kcsf) = acsf(kcsf)%itz
8237	kcsflt(2,kcsf) = acsf(kcsf)%ity
8238	kcsflt(3,kcsf) = acsf(kcsf)%itx
8239	kcsflt(4,kcsf) = acsf(kcsf)%isurfs
8240	ENDDO
8241	!-- last blank blocks at the end of array
8242	j = j+1
8243	IF ( ip>=0 ) icsflt(ip) = j
8244	d = d+j
8245	DO jp = ip+1, numprocs-1
8246	!-- number of elements is zero, displacement is equal to previous
8247	icsflt(jp) = 0
8248	dcsflt(jp) = d
8249	ENDDO
8250
8251	!-- deallocate temporary acsf array
8252	!-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target
8253	!-- via pointing pointer - we need to test original targets
8254	IF ( ALLOCATED(acsf1) ) THEN
8255	DEALLOCATE(acsf1)
8256	ENDIF
8257	IF ( ALLOCATED(acsf2) ) THEN
8258	DEALLOCATE(acsf2)
8259	ENDIF
8260
8261	#if defined( __parallel )
8262	!-- scatter and gather the number of elements to and from all processor
8263	!-- and calculate displacements
8264	IF ( debug_output ) CALL debug_message( 'Scatter and gather the number of elements to and from all processor', 'info' )
8265
8266	CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr)
8267
8268	IF ( ierr /= 0 ) THEN
8269	WRITE(9,*) 'Error MPI_AlltoAll1:', ierr, SIZE(icsflt), SIZE(ipcsflt)
8270	FLUSH(9)
8271	ENDIF
8272
8273	npcsfl = SUM(ipcsflt)
8274	d = 0
8275	DO i = 0, numprocs-1
8276	dpcsflt(i) = d
8277	d = d + ipcsflt(i)
8278	ENDDO
8279
8280	!-- exchange csf fields between processors
8281	IF ( debug_output ) CALL debug_message( 'Exchange csf fields between processors', 'info' )
8282	udim = max(npcsfl,1)
8283	ALLOCATE( pcsflt_l(ndcsf*udim) )
8284	pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim)
8285	ALLOCATE( kpcsflt_l(kdcsf*udim) )
8286	kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim)
8287	CALL MPI_AlltoAllv(csflt_l, ndcsficsflt, ndcsfdcsflt, MPI_REAL, &
8288	pcsflt_l, ndcsfipcsflt, ndcsfdpcsflt, MPI_REAL, comm2d, ierr)
8289	IF ( ierr /= 0 ) THEN
8290	WRITE(9,) 'Error MPI_AlltoAllv1:', ierr, SIZE(ipcsflt), ndcsficsflt, &
8291	ndcsfdcsflt, SIZE(pcsflt_l),ndcsfipcsflt, ndcsf*dpcsflt
8292	FLUSH(9)
8293	ENDIF
8294
8295	CALL MPI_AlltoAllv(kcsflt_l, kdcsficsflt, kdcsfdcsflt, MPI_INTEGER, &
8296	kpcsflt_l, kdcsfipcsflt, kdcsfdpcsflt, MPI_INTEGER, comm2d, ierr)
8297	IF ( ierr /= 0 ) THEN
8298	WRITE(9,) 'Error MPI_AlltoAllv2:', ierr, SIZE(kcsflt_l),kdcsficsflt, &
8299	kdcsfdcsflt, SIZE(kpcsflt_l), kdcsfipcsflt, kdcsf*dpcsflt
8300	FLUSH(9)
8301	ENDIF
8302
8303	#else
8304	npcsfl = ncsfl
8305	ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) )
8306	ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) )
8307	pcsflt = csflt
8308	kpcsflt = kcsflt
8309	#endif
8310
8311	!-- deallocate temporary arrays
8312	DEALLOCATE( csflt_l )
8313	DEALLOCATE( kcsflt_l )
8314	DEALLOCATE( icsflt )
8315	DEALLOCATE( dcsflt )
8316	DEALLOCATE( ipcsflt )
8317	DEALLOCATE( dpcsflt )
8318
8319	!-- sort csf ( a version of quicksort )
8320	IF ( debug_output ) CALL debug_message( 'Sort csf', 'info' )
8321	CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl)
8322
8323	!-- aggregate canopy sink factor records with identical box & source
8324	!-- againg across all values from all processors
8325	IF ( debug_output ) CALL debug_message( 'Aggregate canopy sink factor records with identical box', 'info' )
8326
8327	IF ( npcsfl > 0 ) THEN
8328	icsf = 1 !< reading index
8329	kcsf = 1 !< writing index
8330	DO WHILE (icsf < npcsfl)
8331	!-- here kpcsf(kcsf) already has values from kpcsf(icsf)
8332	IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. &
8333	kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. &
8334	kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. &
8335	kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN
8336
8337	pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1)
8338
8339	!-- advance reading index, keep writing index
8340	icsf = icsf + 1
8341	ELSE
8342	!-- not identical, just advance and copy
8343	icsf = icsf + 1
8344	kcsf = kcsf + 1
8345	kpcsflt(:,kcsf) = kpcsflt(:,icsf)
8346	pcsflt(:,kcsf) = pcsflt(:,icsf)
8347	ENDIF
8348	ENDDO
8349	!-- last written item is now also the last item in valid part of array
8350	npcsfl = kcsf
8351	ENDIF
8352
8353	ncsfl = npcsfl
8354	IF ( ncsfl > 0 ) THEN
8355	ALLOCATE( csf(ndcsf,ncsfl) )
8356	ALLOCATE( csfsurf(idcsf,ncsfl) )
8357	DO icsf = 1, ncsfl
8358	csf(:,icsf) = pcsflt(:,icsf)
8359	csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf))
8360	csfsurf(2,icsf) = kpcsflt(4,icsf)
8361	ENDDO
8362	ENDIF
8363
8364	!-- deallocation of temporary arrays
8365	IF ( npcbl > 0 ) DEALLOCATE( gridpcbl )
8366	DEALLOCATE( pcsflt_l )
8367	DEALLOCATE( kpcsflt_l )
8368	IF ( debug_output ) THEN
8369	WRITE( debug_string, '("Finished aggregating ",I0," CSFs.")') ncsfl
8370	CALL debug_message( debug_string, 'info' )
8371	ENDIF
8372
8373	ENDIF
8374
8375	#if defined( __parallel )
8376	CALL MPI_BARRIER( comm2d, ierr )
8377	#endif
8378	CALL location_message( 'calculating view factors for radiation interaction', 'finished' )
8379
8380	RETURN !todo: remove
8381
8382	! WRITE( message_string, * ) &
8383	! 'I/O error when processing shape view factors / ', &
8384	! 'plant canopy sink factors / direct irradiance factors.'
8385	! CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 )
8386
8387	END SUBROUTINE radiation_calc_svf
8388
8389
8390	!------------------------------------------------------------------------------!
8391	! Description:
8392	! ------------
8393	!> Raytracing for detecting obstacles and calculating compound canopy sink
8394	!> factors for RTM. (A simple obstacle detection would only need to process
8395	!> faces in 3 dimensions without any ordering.)
8396	!> Assumtions:
8397	!> -----------
8398	!> 1. The ray always originates from a face midpoint (only one coordinate equals
8399	!> *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean
8400	!> shape factor=0). Therefore, the ray may never travel exactly along a face
8401	!> or an edge.
8402	!> 2. From grid bottom to urban surface top the grid has to be equidistant
8403	!> within each of the dimensions, including vertical (but the resolution
8404	!> doesn't need to be the same in all three dimensions).
8405	!------------------------------------------------------------------------------!
8406	SUBROUTINE raytrace(src, targ, isrc, difvf, atarg, create_csf, visible, transparency)
8407	IMPLICIT NONE
8408
8409	REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x
8410	INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf
8411	REAL(wp), INTENT(in) :: difvf !< differential view factor for csf
8412	REAL(wp), INTENT(in) :: atarg !< target surface area for csf
8413	LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing
8414	LOGICAL, INTENT(out) :: visible
8415	REAL(wp), INTENT(out) :: transparency !< along whole path
8416	INTEGER(iwp) :: i, k, d
8417	INTEGER(iwp) :: seldim !< dimension to be incremented
8418	INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes
8419	INTEGER(iwp) :: maxboxes !< max no of gridboxes visited
8420	REAL(wp) :: distance !< euclidean along path
8421	REAL(wp) :: crlen !< length of gridbox crossing
8422	REAL(wp) :: lastdist !< beginning of current crossing
8423	REAL(wp) :: nextdist !< end of current crossing
8424	REAL(wp) :: realdist !< distance in meters per unit distance
8425	REAL(wp) :: crmid !< midpoint of crossing
8426	REAL(wp) :: cursink !< sink factor for current canopy box
8427	REAL(wp), DIMENSION(3) :: delta !< path vector
8428	REAL(wp), DIMENSION(3) :: uvect !< unit vector
8429	REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments
8430	INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed
8431	INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path
8432	INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1
8433	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
8434	!< the processor in the question
8435	INTEGER(iwp) :: ip !< number of processor where gridbox reside
8436	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
8437
8438	REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison
8439	REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box
8440
8441	!
8442	!-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also
8443	!-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor.
8444	maxboxes = SUM(ABS(NINT(targ, iwp) - NINT(src, iwp))) + 1
8445	IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN
8446	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
8447	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
8448	!-- / log(grow_factor)), kind=wp))
8449	!-- or use this code to simply always keep some extra space after growing
8450	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
8451
8452	CALL merge_and_grow_csf(k)
8453	ENDIF
8454
8455	transparency = 1._wp
8456	ncsb = 0
8457
8458	delta(:) = targ(:) - src(:)
8459	distance = SQRT(SUM(delta(:)**2))
8460	IF ( distance == 0._wp ) THEN
8461	visible = .TRUE.
8462	RETURN
8463	ENDIF
8464	uvect(:) = delta(:) / distance
8465	realdist = SQRT(SUM( (uvect(:)(/dz(1),dy,dx/))*2 ))
8466
8467	lastdist = 0._wp
8468
8469	!-- Since all face coordinates have values *.5 and we'd like to use
8470	!-- integers, all these have .5 added
8471	DO d = 1, 3
8472	IF ( uvect(d) == 0._wp ) THEN
8473	dimnext(d) = 999999999
8474	dimdelta(d) = 999999999
8475	dimnextdist(d) = 1.0E20_wp
8476	ELSE IF ( uvect(d) > 0._wp ) THEN
8477	dimnext(d) = CEILING(src(d) + .5_wp)
8478	dimdelta(d) = 1
8479	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
8480	ELSE
8481	dimnext(d) = FLOOR(src(d) + .5_wp)
8482	dimdelta(d) = -1
8483	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
8484	ENDIF
8485	ENDDO
8486
8487	DO
8488	!-- along what dimension will the next wall crossing be?
8489	seldim = minloc(dimnextdist, 1)
8490	nextdist = dimnextdist(seldim)
8491	IF ( nextdist > distance ) nextdist = distance
8492
8493	crlen = nextdist - lastdist
8494	IF ( crlen > .001_wp ) THEN
8495	crmid = (lastdist + nextdist) * .5_wp
8496	box = NINT(src(:) + uvect(:) * crmid, iwp)
8497
8498	!-- calculate index of the grid with global indices (box(2),box(3))
8499	!-- in the array nzterr and plantt and id of the coresponding processor
8500	px = box(3)/nnx
8501	py = box(2)/nny
8502	ip = px*pdims(2)+py
8503	ig = ipnnxnny + (box(3)-pxnnx)nny + box(2)-py*nny
8504	IF ( box(1) <= nzterr(ig) ) THEN
8505	visible = .FALSE.
8506	RETURN
8507	ENDIF
8508
8509	IF ( plant_canopy ) THEN
8510	IF ( box(1) <= plantt(ig) ) THEN
8511	ncsb = ncsb + 1
8512	boxes(:,ncsb) = box
8513	crlens(ncsb) = crlen
8514	#if defined( __parallel )
8515	lad_ip(ncsb) = ip
8516	lad_disp(ncsb) = (box(3)-pxnnx)(nnynz_plant) + (box(2)-pynny)*nz_plant + box(1)-nz_urban_b
8517	#endif
8518	ENDIF
8519	ENDIF
8520	ENDIF
8521
8522	IF ( ABS(distance - nextdist) < eps ) EXIT
8523	lastdist = nextdist
8524	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
8525	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim)
8526	ENDDO
8527
8528	IF ( plant_canopy ) THEN
8529	#if defined( __parallel )
8530	IF ( raytrace_mpi_rma ) THEN
8531	!-- send requests for lad_s to appropriate processor
8532	CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'start' )
8533	DO i = 1, ncsb
8534	CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), &
8535	1, MPI_REAL, win_lad, ierr)
8536	IF ( ierr /= 0 ) THEN
8537	WRITE(9,*) 'Error MPI_Get1:', ierr, lad_s_ray(i), &
8538	lad_ip(i), lad_disp(i), win_lad
8539	FLUSH(9)
8540	ENDIF
8541	ENDDO
8542
8543	!-- wait for all pending local requests complete
8544	CALL MPI_Win_flush_local_all(win_lad, ierr)
8545	IF ( ierr /= 0 ) THEN
8546	WRITE(9,*) 'Error MPI_Win_flush_local_all1:', ierr, win_lad
8547	FLUSH(9)
8548	ENDIF
8549	CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'stop' )
8550
8551	ENDIF
8552	#endif
8553
8554	!-- calculate csf and transparency
8555	DO i = 1, ncsb
8556	#if defined( __parallel )
8557	IF ( raytrace_mpi_rma ) THEN
8558	lad_s_target = lad_s_ray(i)
8559	ELSE
8560	lad_s_target = sub_lad_g(lad_ip(i)nnxnny*nz_plant + lad_disp(i))
8561	ENDIF
8562	#else
8563	lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i))
8564	#endif
8565	cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist)
8566
8567	IF ( create_csf ) THEN
8568	!-- write svf values into the array
8569	ncsfl = ncsfl + 1
8570	acsf(ncsfl)%ip = lad_ip(i)
8571	acsf(ncsfl)%itx = boxes(3,i)
8572	acsf(ncsfl)%ity = boxes(2,i)
8573	acsf(ncsfl)%itz = boxes(1,i)
8574	acsf(ncsfl)%isurfs = isrc
8575	acsf(ncsfl)%rcvf = cursinktransparencydifvf*atarg
8576	ENDIF !< create_csf
8577
8578	transparency = transparency * (1._wp - cursink)
8579
8580	ENDDO
8581	ENDIF
8582
8583	visible = .TRUE.
8584
8585	END SUBROUTINE raytrace
8586
8587
8588	!------------------------------------------------------------------------------!
8589	! Description:
8590	! ------------
8591	!> A new, more efficient version of ray tracing algorithm that processes a whole
8592	!> arc instead of a single ray (new in RTM version 2.5).
8593	!>
8594	!> In all comments, horizon means tangent of horizon angle, i.e.
8595	!> vertical_delta / horizontal_distance
8596	!------------------------------------------------------------------------------!
8597	SUBROUTINE raytrace_2d(origin, yxdir, nrays, zdirs, iorig, aorig, vffrac, &
8598	calc_svf, create_csf, skip_1st_pcb, &
8599	lowest_free_ray, transparency, itarget)
8600	IMPLICIT NONE
8601
8602	REAL(wp), DIMENSION(3), INTENT(IN) :: origin !< z,y,x coordinates of ray origin
8603	REAL(wp), DIMENSION(2), INTENT(IN) :: yxdir !< y,x unit vector of ray direction (in grid units)
8604	INTEGER(iwp) :: nrays !< number of rays (z directions) to raytrace
8605	REAL(wp), DIMENSION(nrays), INTENT(IN) :: zdirs !< list of z directions to raytrace (z/hdist, grid, zenith->nadir)
8606	INTEGER(iwp), INTENT(in) :: iorig !< index of origin face for csf
8607	REAL(wp), INTENT(in) :: aorig !< origin face area for csf
8608	REAL(wp), DIMENSION(nrays), INTENT(in) :: vffrac !< view factor fractions of each ray for csf
8609	LOGICAL, INTENT(in) :: calc_svf !< whether to calculate SFV (identify obstacle surfaces)
8610	LOGICAL, INTENT(in) :: create_csf !< whether to create canopy sink factors
8611	LOGICAL, INTENT(in) :: skip_1st_pcb !< whether to skip first plant canopy box during raytracing
8612	INTEGER(iwp), INTENT(out) :: lowest_free_ray !< index into zdirs
8613	REAL(wp), DIMENSION(nrays), INTENT(OUT) :: transparency !< transparencies of zdirs paths
8614	INTEGER(iwp), DIMENSION(nrays), INTENT(OUT) :: itarget !< global indices of target faces for zdirs
8615
8616	INTEGER(iwp), DIMENSION(nrays) :: target_procs
8617	REAL(wp) :: horizon !< highest horizon found after raytracing (z/hdist)
8618	INTEGER(iwp) :: i, k, l, d
8619	INTEGER(iwp) :: seldim !< dimension to be incremented
8620	REAL(wp), DIMENSION(2) :: yxorigin !< horizontal copy of origin (y,x)
8621	REAL(wp) :: distance !< euclidean along path
8622	REAL(wp) :: lastdist !< beginning of current crossing
8623	REAL(wp) :: nextdist !< end of current crossing
8624	REAL(wp) :: crmid !< midpoint of crossing
8625	REAL(wp) :: horz_entry !< horizon at entry to column
8626	REAL(wp) :: horz_exit !< horizon at exit from column
8627	REAL(wp) :: bdydim !< boundary for current dimension
8628	REAL(wp), DIMENSION(2) :: crossdist !< distances to boundary for dimensions
8629	REAL(wp), DIMENSION(2) :: dimnextdist !< distance for each dimension increments
8630	INTEGER(iwp), DIMENSION(2) :: column !< grid column being crossed
8631	INTEGER(iwp), DIMENSION(2) :: dimnext !< next dimension increments along path
8632	INTEGER(iwp), DIMENSION(2) :: dimdelta !< dimension direction = +- 1
8633	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
8634	!< the processor in the question
8635	INTEGER(iwp) :: ip !< number of processor where gridbox reside
8636	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
8637	INTEGER(iwp) :: maxboxes !< max no of CSF created
8638	INTEGER(iwp) :: nly !< maximum plant canopy height
8639	INTEGER(iwp) :: ntrack
8640
8641	INTEGER(iwp) :: zb0
8642	INTEGER(iwp) :: zb1
8643	INTEGER(iwp) :: nz
8644	INTEGER(iwp) :: iz
8645	INTEGER(iwp) :: zsgn
8646	INTEGER(iwp) :: lastdir !< wall direction before hitting this column
8647	INTEGER(iwp), DIMENSION(2) :: lastcolumn
8648
8649	#if defined( __parallel )
8650	INTEGER(iwp) :: lowest_lad !< lowest column cell for which we need LAD
8651	INTEGER(iwp) :: wcount !< RMA window item count
8652	INTEGER(MPI_ADDRESS_KIND) :: wdisp !< RMA window displacement
8653	#endif
8654
8655	REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison
8656	REAL(wp) :: zbottom, ztop !< urban surface boundary in real numbers
8657	REAL(wp) :: zorig !< z coordinate of ray column entry
8658	REAL(wp) :: zexit !< z coordinate of ray column exit
8659	REAL(wp) :: qdist !< ratio of real distance to z coord difference
8660	REAL(wp) :: dxxyy !< square of real horizontal distance
8661	REAL(wp) :: curtrans !< transparency of current PC box crossing
8662
8663
8664
8665	yxorigin(:) = origin(2:3)
8666	transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing
8667	horizon = -HUGE(1._wp)
8668	lowest_free_ray = nrays
8669	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8670	ALLOCATE(target_surfl(nrays))
8671	target_surfl(:) = -1
8672	lastdir = -999
8673	lastcolumn(:) = -999
8674	ENDIF
8675
8676	!-- Determine distance to boundary (in 2D xy)
8677	IF ( yxdir(1) > 0._wp ) THEN
8678	bdydim = ny + .5_wp !< north global boundary
8679	crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8680	ELSEIF ( yxdir(1) == 0._wp ) THEN
8681	crossdist(1) = HUGE(1._wp)
8682	ELSE
8683	bdydim = -.5_wp !< south global boundary
8684	crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8685	ENDIF
8686
8687	IF ( yxdir(2) > 0._wp ) THEN
8688	bdydim = nx + .5_wp !< east global boundary
8689	crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8690	ELSEIF ( yxdir(2) == 0._wp ) THEN
8691	crossdist(2) = HUGE(1._wp)
8692	ELSE
8693	bdydim = -.5_wp !< west global boundary
8694	crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8695	ENDIF
8696	distance = minval(crossdist, 1)
8697
8698	IF ( plant_canopy ) THEN
8699	rt2_track_dist(0) = 0._wp
8700	rt2_track_lad(:,:) = 0._wp
8701	nly = plantt_max - nz_urban_b + 1
8702	ENDIF
8703
8704	lastdist = 0._wp
8705
8706	!-- Since all face coordinates have values *.5 and we'd like to use
8707	!-- integers, all these have .5 added
8708	DO d = 1, 2
8709	IF ( yxdir(d) == 0._wp ) THEN
8710	dimnext(d) = HUGE(1_iwp)
8711	dimdelta(d) = HUGE(1_iwp)
8712	dimnextdist(d) = HUGE(1._wp)
8713	ELSE IF ( yxdir(d) > 0._wp ) THEN
8714	dimnext(d) = FLOOR(yxorigin(d) + .5_wp) + 1
8715	dimdelta(d) = 1
8716	dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8717	ELSE
8718	dimnext(d) = CEILING(yxorigin(d) + .5_wp) - 1
8719	dimdelta(d) = -1
8720	dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8721	ENDIF
8722	ENDDO
8723
8724	ntrack = 0
8725	DO
8726	!-- along what dimension will the next wall crossing be?
8727	seldim = minloc(dimnextdist, 1)
8728	nextdist = dimnextdist(seldim)
8729	IF ( nextdist > distance ) nextdist = distance
8730
8731	IF ( nextdist > lastdist ) THEN
8732	ntrack = ntrack + 1
8733	crmid = (lastdist + nextdist) * .5_wp
8734	column = NINT(yxorigin(:) + yxdir(:) * crmid, iwp)
8735
8736	!-- calculate index of the grid with global indices (column(1),column(2))
8737	!-- in the array nzterr and plantt and id of the coresponding processor
8738	px = column(2)/nnx
8739	py = column(1)/nny
8740	ip = px*pdims(2)+py
8741	ig = ipnnxnny + (column(2)-pxnnx)nny + column(1)-py*nny
8742
8743	IF ( lastdist == 0._wp ) THEN
8744	horz_entry = -HUGE(1._wp)
8745	ELSE
8746	horz_entry = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / lastdist
8747	ENDIF
8748	horz_exit = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / nextdist
8749
8750	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8751	!
8752	!-- Identify vertical obstacles hit by rays in current column
8753	DO WHILE ( lowest_free_ray > 0 )
8754	IF ( zdirs(lowest_free_ray) > horz_entry ) EXIT
8755	!
8756	!-- This may only happen after 1st column, so lastdir and lastcolumn are valid
8757	CALL request_itarget(lastdir, &
8758	CEILING(-0.5_wp + origin(1) + zdirs(lowest_free_ray)*lastdist), &
8759	lastcolumn(1), lastcolumn(2), &
8760	target_surfl(lowest_free_ray), target_procs(lowest_free_ray))
8761	lowest_free_ray = lowest_free_ray - 1
8762	ENDDO
8763	!
8764	!-- Identify horizontal obstacles hit by rays in current column
8765	DO WHILE ( lowest_free_ray > 0 )
8766	IF ( zdirs(lowest_free_ray) > horz_exit ) EXIT
8767	CALL request_itarget(iup_u, nzterr(ig)+1, column(1), column(2), &
8768	target_surfl(lowest_free_ray), &
8769	target_procs(lowest_free_ray))
8770	lowest_free_ray = lowest_free_ray - 1
8771	ENDDO
8772	ENDIF
8773
8774	horizon = MAX(horizon, horz_entry, horz_exit)
8775
8776	IF ( plant_canopy ) THEN
8777	rt2_track(:, ntrack) = column(:)
8778	rt2_track_dist(ntrack) = nextdist
8779	ENDIF
8780	ENDIF
8781
8782	IF ( nextdist + eps >= distance ) EXIT
8783
8784	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8785	!
8786	!-- Save wall direction of coming building column (= this air column)
8787	IF ( seldim == 1 ) THEN
8788	IF ( dimdelta(seldim) == 1 ) THEN
8789	lastdir = isouth_u
8790	ELSE
8791	lastdir = inorth_u
8792	ENDIF
8793	ELSE
8794	IF ( dimdelta(seldim) == 1 ) THEN
8795	lastdir = iwest_u
8796	ELSE
8797	lastdir = ieast_u
8798	ENDIF
8799	ENDIF
8800	lastcolumn = column
8801	ENDIF
8802	lastdist = nextdist
8803	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
8804	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - yxorigin(seldim)) / yxdir(seldim)
8805	ENDDO
8806
8807	IF ( plant_canopy ) THEN
8808	!-- Request LAD WHERE applicable
8809	!--
8810	#if defined( __parallel )
8811	IF ( raytrace_mpi_rma ) THEN
8812	!-- send requests for lad_s to appropriate processor
8813	!CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' )
8814	DO i = 1, ntrack
8815	px = rt2_track(2,i)/nnx
8816	py = rt2_track(1,i)/nny
8817	ip = px*pdims(2)+py
8818	ig = ipnnxnny + (rt2_track(2,i)-pxnnx)nny + rt2_track(1,i)-py*nny
8819
8820	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8821	!
8822	!-- For fixed view resolution, we need plant canopy even for rays
8823	!-- to opposing surfaces
8824	lowest_lad = nzterr(ig) + 1
8825	ELSE
8826	!
8827	!-- We only need LAD for rays directed above horizon (to sky)
8828	lowest_lad = CEILING( -0.5_wp + origin(1) + &
8829	MIN( horizon * rt2_track_dist(i-1), & ! entry
8830	horizon * rt2_track_dist(i) ) ) ! exit
8831	ENDIF
8832	!
8833	!-- Skip asking for LAD where all plant canopy is under requested level
8834	IF ( plantt(ig) < lowest_lad ) CYCLE
8835
8836	wdisp = (rt2_track(2,i)-pxnnx)(nnynz_plant) + (rt2_track(1,i)-pynny)*nz_plant + lowest_lad-nz_urban_b
8837	wcount = plantt(ig)-lowest_lad+1
8838	! TODO send request ASAP - even during raytracing
8839	CALL MPI_Get(rt2_track_lad(lowest_lad:plantt(ig), i), wcount, MPI_REAL, ip, &
8840	wdisp, wcount, MPI_REAL, win_lad, ierr)
8841	IF ( ierr /= 0 ) THEN
8842	WRITE(9,*) 'Error MPI_Get2:', ierr, rt2_track_lad(lowest_lad:plantt(ig), i), &
8843	wcount, ip, wdisp, win_lad
8844	FLUSH(9)
8845	ENDIF
8846	ENDDO
8847
8848	!-- wait for all pending local requests complete
8849	! TODO WAIT selectively for each column later when needed
8850	CALL MPI_Win_flush_local_all(win_lad, ierr)
8851	IF ( ierr /= 0 ) THEN
8852	WRITE(9,*) 'Error MPI_Win_flush_local_all2:', ierr, win_lad
8853	FLUSH(9)
8854	ENDIF
8855	!CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' )
8856
8857	ELSE ! raytrace_mpi_rma = .F.
8858	DO i = 1, ntrack
8859	px = rt2_track(2,i)/nnx
8860	py = rt2_track(1,i)/nny
8861	ip = px*pdims(2)+py
8862	ig = ipnnxnnynz_plant + (rt2_track(2,i)-pxnnx)(nnynz_plant) + (rt2_track(1,i)-pynny)nz_plant
8863	rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad_g(ig:ig+nly-1)
8864	ENDDO
8865	ENDIF
8866	#else
8867	DO i = 1, ntrack
8868	rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), nz_urban_b:plantt_max)
8869	ENDDO
8870	#endif
8871	ENDIF ! plant_canopy
8872
8873	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8874	#if defined( __parallel )
8875	!-- wait for all gridsurf requests to complete
8876	CALL MPI_Win_flush_local_all(win_gridsurf, ierr)
8877	IF ( ierr /= 0 ) THEN
8878	WRITE(9,*) 'Error MPI_Win_flush_local_all3:', ierr, win_gridsurf
8879	FLUSH(9)
8880	ENDIF
8881	#endif
8882	!
8883	!-- recalculate local surf indices into global ones
8884	DO i = 1, nrays
8885	IF ( target_surfl(i) == -1 ) THEN
8886	itarget(i) = -1
8887	ELSE
8888	itarget(i) = target_surfl(i) + surfstart(target_procs(i))
8889	ENDIF
8890	ENDDO
8891
8892	DEALLOCATE( target_surfl )
8893
8894	ELSE
8895	itarget(:) = -1
8896	ENDIF ! rad_angular_discretization
8897
8898	IF ( plant_canopy ) THEN
8899	!-- Skip the PCB around origin if requested (for MRT, the PCB might not be there)
8900	!--
8901	IF ( skip_1st_pcb .AND. NINT(origin(1)) <= plantt_max ) THEN
8902	rt2_track_lad(NINT(origin(1), iwp), 1) = 0._wp
8903	ENDIF
8904
8905	!-- Assert that we have space allocated for CSFs
8906	!--
8907	maxboxes = (ntrack + MAX(CEILING(origin(1)-.5_wp) - nz_urban_b, &
8908	nz_urban_t - CEILING(origin(1)-.5_wp))) * nrays
8909	IF ( ncsfl + maxboxes > ncsfla ) THEN
8910	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
8911	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
8912	!-- / log(grow_factor)), kind=wp))
8913	!-- or use this code to simply always keep some extra space after growing
8914	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
8915	CALL merge_and_grow_csf(k)
8916	ENDIF
8917
8918	!-- Calculate transparencies and store new CSFs
8919	!--
8920	zbottom = REAL(nz_urban_b, wp) - .5_wp
8921	ztop = REAL(plantt_max, wp) + .5_wp
8922
8923	!-- Reverse direction of radiation (face->sky), only when calc_svf
8924	!--
8925	IF ( calc_svf ) THEN
8926	DO i = 1, ntrack ! for each column
8927	dxxyy = ((dyyxdir(1))2 + (dxyxdir(2))*2) (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8928	px = rt2_track(2,i)/nnx
8929	py = rt2_track(1,i)/nny
8930	ip = px*pdims(2)+py
8931
8932	DO k = 1, nrays ! for each ray
8933	!
8934	!-- NOTE 6778:
8935	!-- With traditional svf discretization, CSFs under the horizon
8936	!-- (i.e. for surface to surface radiation) are created in
8937	!-- raytrace(). With rad_angular_discretization, we must create
8938	!-- CSFs under horizon only for one direction, otherwise we would
8939	!-- have duplicate amount of energy. Although we could choose
8940	!-- either of the two directions (they differ only by
8941	!-- discretization error with no bias), we choose the the backward
8942	!-- direction, because it tends to cumulate high canopy sink
8943	!-- factors closer to raytrace origin, i.e. it should potentially
8944	!-- cause less moiree.
8945	IF ( .NOT. rad_angular_discretization ) THEN
8946	IF ( zdirs(k) <= horizon ) CYCLE
8947	ENDIF
8948
8949	zorig = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8950	IF ( zorig <= zbottom .OR. zorig >= ztop ) CYCLE
8951
8952	zsgn = INT(SIGN(1._wp, zdirs(k)), iwp)
8953	rt2_dist(1) = 0._wp
8954	IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal
8955	nz = 2
8956	rt2_dist(nz) = SQRT(dxxyy)
8957	iz = CEILING(-.5_wp + zorig, iwp)
8958	ELSE
8959	zexit = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8960
8961	zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig
8962	zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit
8963	nz = MAX(zb1 - zb0 + 3, 2)
8964	rt2_dist(nz) = SQRT(((zexit-zorig)dz(1))*2 + dxxyy)
8965	qdist = rt2_dist(nz) / (zexit-zorig)
8966	rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8967	iz = zb0 * zsgn
8968	ENDIF
8969
8970	DO l = 2, nz
8971	IF ( rt2_track_lad(iz, i) > 0._wp ) THEN
8972	curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8973
8974	IF ( create_csf ) THEN
8975	ncsfl = ncsfl + 1
8976	acsf(ncsfl)%ip = ip
8977	acsf(ncsfl)%itx = rt2_track(2,i)
8978	acsf(ncsfl)%ity = rt2_track(1,i)
8979	acsf(ncsfl)%itz = iz
8980	acsf(ncsfl)%isurfs = iorig
8981	acsf(ncsfl)%rcvf = (1._wp - curtrans)transparency(k)vffrac(k)
8982	ENDIF
8983
8984	transparency(k) = transparency(k) * curtrans
8985	ENDIF
8986	iz = iz + zsgn
8987	ENDDO ! l = 1, nz - 1
8988	ENDDO ! k = 1, nrays
8989	ENDDO ! i = 1, ntrack
8990
8991	transparency(1:lowest_free_ray) = 1._wp !-- Reset rays above horizon to transparent (see NOTE 6778)
8992	ENDIF
8993
8994	!-- Forward direction of radiation (sky->face), always
8995	!--
8996	DO i = ntrack, 1, -1 ! for each column backwards
8997	dxxyy = ((dyyxdir(1))2 + (dxyxdir(2))*2) (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8998	px = rt2_track(2,i)/nnx
8999	py = rt2_track(1,i)/nny
9000	ip = px*pdims(2)+py
9001
9002	DO k = 1, nrays ! for each ray
9003	!
9004	!-- See NOTE 6778 above
9005	IF ( zdirs(k) <= horizon ) CYCLE
9006
9007	zexit = origin(1) + zdirs(k) * rt2_track_dist(i-1)
9008	IF ( zexit <= zbottom .OR. zexit >= ztop ) CYCLE
9009
9010	zsgn = -INT(SIGN(1._wp, zdirs(k)), iwp)
9011	rt2_dist(1) = 0._wp
9012	IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal
9013	nz = 2
9014	rt2_dist(nz) = SQRT(dxxyy)
9015	iz = NINT(zexit, iwp)
9016	ELSE
9017	zorig = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
9018
9019	zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig
9020	zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit
9021	nz = MAX(zb1 - zb0 + 3, 2)
9022	rt2_dist(nz) = SQRT(((zexit-zorig)dz(1))*2 + dxxyy)
9023	qdist = rt2_dist(nz) / (zexit-zorig)
9024	rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
9025	iz = zb0 * zsgn
9026	ENDIF
9027
9028	DO l = 2, nz
9029	IF ( rt2_track_lad(iz, i) > 0._wp ) THEN
9030	curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
9031
9032	IF ( create_csf ) THEN
9033	ncsfl = ncsfl + 1
9034	acsf(ncsfl)%ip = ip
9035	acsf(ncsfl)%itx = rt2_track(2,i)
9036	acsf(ncsfl)%ity = rt2_track(1,i)
9037	acsf(ncsfl)%itz = iz
9038	IF ( itarget(k) /= -1 ) STOP 1 !FIXME remove after test
9039	acsf(ncsfl)%isurfs = -1
9040	acsf(ncsfl)%rcvf = (1._wp - curtrans)transparency(k)aorig*vffrac(k)
9041	ENDIF ! create_csf
9042
9043	transparency(k) = transparency(k) * curtrans
9044	ENDIF
9045	iz = iz + zsgn
9046	ENDDO ! l = 1, nz - 1
9047	ENDDO ! k = 1, nrays
9048	ENDDO ! i = 1, ntrack
9049	ENDIF ! plant_canopy
9050
9051	IF ( .NOT. (rad_angular_discretization .AND. calc_svf) ) THEN
9052	!
9053	!-- Just update lowest_free_ray according to horizon
9054	DO WHILE ( lowest_free_ray > 0 )
9055	IF ( zdirs(lowest_free_ray) > horizon ) EXIT
9056	lowest_free_ray = lowest_free_ray - 1
9057	ENDDO
9058	ENDIF
9059
9060	CONTAINS
9061
9062	SUBROUTINE request_itarget( d, z, y, x, isurfl, iproc )
9063
9064	INTEGER(iwp), INTENT(in) :: d, z, y, x
9065	INTEGER(iwp), TARGET, INTENT(out) :: isurfl
9066	INTEGER(iwp), INTENT(out) :: iproc
9067	#if defined( __parallel )
9068	INTEGER(iwp) :: px, py !< number of processors in x and y direction
9069	!< before the processor in the question
9070	#endif
9071
9072	#if defined( __parallel )
9073	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_displ !< index of the grid in the local gridsurf array
9074
9075	!
9076	!-- Calculate target processor and index in the remote local target gridsurf array
9077	px = x / nnx
9078	py = y / nny
9079	iproc = px * pdims(2) + py
9080	target_displ = ((x-pxnnx) nny + y - pynny ) nz_urban * nsurf_type_u +&
9081	( z-nz_urban_b ) * nsurf_type_u + d
9082	!
9083	!-- Send MPI_Get request to obtain index target_surfl(i)
9084	CALL MPI_GET( isurfl, 1, MPI_INTEGER, iproc, target_displ, &
9085	1, MPI_INTEGER, win_gridsurf, ierr)
9086	IF ( ierr /= 0 ) THEN
9087	WRITE( 9,* ) 'Error MPI_Get3:', ierr, isurfl, iproc, target_displ, &
9088	win_gridsurf
9089	FLUSH( 9 )
9090	ENDIF
9091	#else
9092	!-- set index target_surfl(i)
9093	isurfl = gridsurf(d,z,y,x)
9094	iproc = 0 ! required to avoid compile error about unused variable in serial mode
9095	#endif
9096
9097	END SUBROUTINE request_itarget
9098
9099	END SUBROUTINE raytrace_2d
9100
9101
9102	!------------------------------------------------------------------------------!
9103	!
9104	! Description:
9105	! ------------
9106	!> Calculates apparent solar positions for all timesteps and stores discretized
9107	!> positions for RTM.
9108	!------------------------------------------------------------------------------!
9109	SUBROUTINE radiation_presimulate_solar_pos
9110
9111	IMPLICIT NONE
9112
9113	INTEGER(iwp) :: it, i, j !< loop indices
9114
9115	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir_tmp !< dsidir_tmp[:,i] = unit vector of i-th
9116	!< appreant solar direction
9117
9118	ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1, &
9119	0:raytrace_discrete_azims-1) )
9120	dsidir_rev(:,:) = -1
9121	ALLOCATE ( dsidir_tmp(3, &
9122	raytrace_discrete_elevs/2*raytrace_discrete_azims) )
9123	ndsidir = 0
9124	sun_direction = .TRUE.
9125
9126	!
9127	!-- Process spinup time if configured
9128	IF ( spinup_time > 0._wp ) THEN
9129	DO it = 0, CEILING(spinup_time / dt_spinup)
9130	CALL simulate_pos( it * dt_spinup - spinup_time )
9131	ENDDO
9132	ENDIF
9133	!
9134	!-- Process simulation time
9135	DO it = 0, CEILING(( end_time - spinup_time ) / dt_radiation)
9136	CALL simulate_pos( it * dt_radiation )
9137	ENDDO
9138	!
9139	!-- Allocate global vars which depend on ndsidir
9140	ALLOCATE ( dsidir ( 3, ndsidir ) )
9141	dsidir(:,:) = dsidir_tmp(:, 1:ndsidir)
9142	DEALLOCATE ( dsidir_tmp )
9143
9144	ALLOCATE ( dsitrans(nsurfl, ndsidir) )
9145	ALLOCATE ( dsitransc(npcbl, ndsidir) )
9146	IF ( nmrtbl > 0 ) ALLOCATE ( mrtdsit(nmrtbl, ndsidir) )
9147
9148	WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', &
9149	' from', it, ' timesteps.'
9150	CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 )
9151
9152	CONTAINS
9153
9154	!------------------------------------------------------------------------!
9155	! Description:
9156	! ------------
9157	!> Simuates a single position
9158	!------------------------------------------------------------------------!
9159	SUBROUTINE simulate_pos( time_since_reference_local )
9160
9161	REAL(wp), INTENT(IN) :: time_since_reference_local !< local time since reference
9162	!
9163	!-- Update apparent solar position based on modified t_s_r_p
9164	CALL get_date_time( time_since_reference_local, &
9165	day_of_year=day_of_year, &
9166	second_of_day=second_of_day )
9167	CALL calc_zenith( day_of_year, second_of_day )
9168	IF ( cos_zenith > 0 ) THEN
9169	!--
9170	!-- Identify solar direction vector (discretized number) 1)
9171	i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat) &
9172	/ (2._wppi) raytrace_discrete_azims-.5_wp, iwp), &
9173	raytrace_discrete_azims)
9174	j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
9175	IF ( dsidir_rev(j, i) == -1 ) THEN
9176	ndsidir = ndsidir + 1
9177	dsidir_tmp(:, ndsidir) = &
9178	(/ COS((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs), &
9179	SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) &
9180	* COS((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims), &
9181	SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) &
9182	* SIN((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims) /)
9183	dsidir_rev(j, i) = ndsidir
9184	ENDIF
9185	ENDIF
9186	END SUBROUTINE simulate_pos
9187
9188	END SUBROUTINE radiation_presimulate_solar_pos
9189
9190
9191
9192	!------------------------------------------------------------------------------!
9193	! Description:
9194	! ------------
9195	!> Determines whether two faces are oriented towards each other in RTM. Since the
9196	!> surfaces follow the gird box surfaces, it checks first whether the two surfaces
9197	!> are directed in the same direction, then it checks if the two surfaces are
9198	!> located in confronted direction but facing away from each other, e.g. <--\| \|-->
9199	!------------------------------------------------------------------------------!
9200	PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2)
9201	IMPLICIT NONE
9202	INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2
9203
9204	surface_facing = .FALSE.
9205
9206	!-- first check: are the two surfaces directed in the same direction
9207	IF ( (d==iup_u .OR. d==iup_l ) &
9208	.AND. (d2==iup_u .OR. d2==iup_l) ) RETURN
9209	IF ( (d==isouth_u .OR. d==isouth_l ) &
9210	.AND. (d2==isouth_u .OR. d2==isouth_l) ) RETURN
9211	IF ( (d==inorth_u .OR. d==inorth_l ) &
9212	.AND. (d2==inorth_u .OR. d2==inorth_l) ) RETURN
9213	IF ( (d==iwest_u .OR. d==iwest_l ) &
9214	.AND. (d2==iwest_u .OR. d2==iwest_l ) ) RETURN
9215	IF ( (d==ieast_u .OR. d==ieast_l ) &
9216	.AND. (d2==ieast_u .OR. d2==ieast_l ) ) RETURN
9217
9218	!-- second check: are surfaces facing away from each other
9219	SELECT CASE (d)
9220	CASE (iup_u, iup_l) !< upward facing surfaces
9221	IF ( z2 < z ) RETURN
9222	CASE (isouth_u, isouth_l) !< southward facing surfaces
9223	IF ( y2 > y ) RETURN
9224	CASE (inorth_u, inorth_l) !< northward facing surfaces
9225	IF ( y2 < y ) RETURN
9226	CASE (iwest_u, iwest_l) !< westward facing surfaces
9227	IF ( x2 > x ) RETURN
9228	CASE (ieast_u, ieast_l) !< eastward facing surfaces
9229	IF ( x2 < x ) RETURN
9230	END SELECT
9231
9232	SELECT CASE (d2)
9233	CASE (iup_u) !< ground, roof
9234	IF ( z < z2 ) RETURN
9235	CASE (isouth_u, isouth_l) !< south facing
9236	IF ( y > y2 ) RETURN
9237	CASE (inorth_u, inorth_l) !< north facing
9238	IF ( y < y2 ) RETURN
9239	CASE (iwest_u, iwest_l) !< west facing
9240	IF ( x > x2 ) RETURN
9241	CASE (ieast_u, ieast_l) !< east facing
9242	IF ( x < x2 ) RETURN
9243	CASE (-1)
9244	CONTINUE
9245	END SELECT
9246
9247	surface_facing = .TRUE.
9248
9249	END FUNCTION surface_facing
9250
9251
9252	!------------------------------------------------------------------------------!
9253	!
9254	! Description:
9255	! ------------
9256	!> Reads svf, svfsurf, csf, csfsurf and mrt factors data from saved file.
9257	!> This allows to skip their calculation during of RTM init phase.
9258	!> SVF means sky view factors and CSF means canopy sink factors.
9259	!------------------------------------------------------------------------------!
9260	SUBROUTINE radiation_read_svf
9261
9262	IMPLICIT NONE
9263
9264	CHARACTER(rad_version_len) :: rad_version_field
9265
9266	INTEGER(iwp) :: i
9267	INTEGER(iwp) :: ndsidir_from_file = 0
9268	INTEGER(iwp) :: npcbl_from_file = 0
9269	INTEGER(iwp) :: nsurfl_from_file = 0
9270	INTEGER(iwp) :: nmrtbl_from_file = 0
9271
9272
9273	CALL location_message( 'reading view factors for radiation interaction', 'start' )
9274
9275	DO i = 0, io_blocks-1
9276	IF ( i == io_group ) THEN
9277
9278	!
9279	!-- numprocs_previous_run is only known in case of reading restart
9280	!-- data. If a new initial run which reads svf data is started the
9281	!-- following query will be skipped
9282	IF ( initializing_actions == 'read_restart_data' ) THEN
9283
9284	IF ( numprocs_previous_run /= numprocs ) THEN
9285	WRITE( message_string, * ) 'A different number of ', &
9286	'processors between the run ', &
9287	'that has written the svf data ',&
9288	'and the one that will read it ',&
9289	'is not allowed'
9290	CALL message( 'check_open', 'PA0491', 1, 2, 0, 6, 0 )
9291	ENDIF
9292
9293	ENDIF
9294
9295	!
9296	!-- Open binary file
9297	CALL check_open( 88 )
9298
9299	!
9300	!-- read and check version
9301	READ ( 88 ) rad_version_field
9302	IF ( TRIM(rad_version_field) /= TRIM(rad_version) ) THEN
9303	WRITE( message_string, * ) 'Version of binary SVF file "', &
9304	TRIM(rad_version_field), '" does not match ', &
9305	'the version of model "', TRIM(rad_version), '"'
9306	CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 )
9307	ENDIF
9308
9309	!
9310	!-- read nsvfl, ncsfl, nsurfl, nmrtf
9311	READ ( 88 ) nsvfl, ncsfl, nsurfl_from_file, npcbl_from_file, &
9312	ndsidir_from_file, nmrtbl_from_file, nmrtf
9313
9314	IF ( nsvfl < 0 .OR. ncsfl < 0 ) THEN
9315	WRITE( message_string, * ) 'Wrong number of SVF or CSF'
9316	CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 )
9317	ELSE
9318	WRITE(debug_string,*) 'Number of SVF, CSF, and nsurfl ', &
9319	'to read', nsvfl, ncsfl, &
9320	nsurfl_from_file
9321	IF ( debug_output ) CALL debug_message( debug_string, 'info' )
9322	ENDIF
9323
9324	IF ( nsurfl_from_file /= nsurfl ) THEN
9325	WRITE( message_string, * ) 'nsurfl from SVF file does not ', &
9326	'match calculated nsurfl from ', &
9327	'radiation_interaction_init'
9328	CALL message( 'radiation_read_svf', 'PA0490', 1, 2, 0, 6, 0 )
9329	ENDIF
9330
9331	IF ( npcbl_from_file /= npcbl ) THEN
9332	WRITE( message_string, * ) 'npcbl from SVF file does not ', &
9333	'match calculated npcbl from ', &
9334	'radiation_interaction_init'
9335	CALL message( 'radiation_read_svf', 'PA0493', 1, 2, 0, 6, 0 )
9336	ENDIF
9337
9338	IF ( ndsidir_from_file /= ndsidir ) THEN
9339	WRITE( message_string, * ) 'ndsidir from SVF file does not ', &
9340	'match calculated ndsidir from ', &
9341	'radiation_presimulate_solar_pos'
9342	CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
9343	ENDIF
9344	IF ( nmrtbl_from_file /= nmrtbl ) THEN
9345	WRITE( message_string, * ) 'nmrtbl from SVF file does not ', &
9346	'match calculated nmrtbl from ', &
9347	'radiation_interaction_init'
9348	CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
9349	ELSE
9350	WRITE(debug_string,*) 'Number of nmrtf to read ', nmrtf
9351	IF ( debug_output ) CALL debug_message( debug_string, 'info' )
9352	ENDIF
9353
9354	!
9355	!-- Arrays skyvf, skyvft, dsitrans and dsitransc are allready
9356	!-- allocated in radiation_interaction_init and
9357	!-- radiation_presimulate_solar_pos
9358	IF ( nsurfl > 0 ) THEN
9359	READ(88) skyvf
9360	READ(88) skyvft
9361	READ(88) dsitrans
9362	ENDIF
9363
9364	IF ( plant_canopy .AND. npcbl > 0 ) THEN
9365	READ ( 88 ) dsitransc
9366	ENDIF
9367
9368	!
9369	!-- The allocation of svf, svfsurf, csf, csfsurf, mrtf, mrtft, and
9370	!-- mrtfsurf happens in routine radiation_calc_svf which is not
9371	!-- called if the program enters radiation_read_svf. Therefore
9372	!-- these arrays has to allocate in the following
9373	IF ( nsvfl > 0 ) THEN
9374	ALLOCATE( svf(ndsvf,nsvfl) )
9375	ALLOCATE( svfsurf(idsvf,nsvfl) )
9376	READ(88) svf
9377	READ(88) svfsurf
9378	ENDIF
9379
9380	IF ( plant_canopy .AND. ncsfl > 0 ) THEN
9381	ALLOCATE( csf(ndcsf,ncsfl) )
9382	ALLOCATE( csfsurf(idcsf,ncsfl) )
9383	READ(88) csf
9384	READ(88) csfsurf
9385	ENDIF
9386
9387	IF ( nmrtbl > 0 ) THEN
9388	READ(88) mrtsky
9389	READ(88) mrtskyt
9390	READ(88) mrtdsit
9391	ENDIF
9392
9393	IF ( nmrtf > 0 ) THEN
9394	ALLOCATE ( mrtf(nmrtf) )
9395	ALLOCATE ( mrtft(nmrtf) )
9396	ALLOCATE ( mrtfsurf(2,nmrtf) )
9397	READ(88) mrtf
9398	READ(88) mrtft
9399	READ(88) mrtfsurf
9400	ENDIF
9401
9402	!
9403	!-- Close binary file
9404	CALL close_file( 88 )
9405
9406	ENDIF
9407	#if defined( __parallel )
9408	CALL MPI_BARRIER( comm2d, ierr )
9409	#endif
9410	ENDDO
9411
9412	CALL location_message( 'reading view factors for radiation interaction', 'finished' )
9413
9414
9415	END SUBROUTINE radiation_read_svf
9416
9417
9418	!------------------------------------------------------------------------------!
9419	!
9420	! Description:
9421	! ------------
9422	!> Subroutine stores svf, svfsurf, csf, csfsurf and mrt data to a file.
9423	!> The stored factors can be reused in future simulation with the same
9424	!> geometry structure of the surfaces and resolved plant canopy.
9425	!------------------------------------------------------------------------------!
9426	SUBROUTINE radiation_write_svf
9427
9428	IMPLICIT NONE
9429
9430	INTEGER(iwp) :: i
9431
9432
9433	CALL location_message( 'writing view factors for radiation interaction', 'start' )
9434
9435	DO i = 0, io_blocks-1
9436	IF ( i == io_group ) THEN
9437	!
9438	!-- Open binary file
9439	CALL check_open( 89 )
9440
9441	WRITE ( 89 ) rad_version
9442	WRITE ( 89 ) nsvfl, ncsfl, nsurfl, npcbl, ndsidir, nmrtbl, nmrtf
9443	IF ( nsurfl > 0 ) THEN
9444	WRITE ( 89 ) skyvf
9445	WRITE ( 89 ) skyvft
9446	WRITE ( 89 ) dsitrans
9447	ENDIF
9448	IF ( npcbl > 0 ) THEN
9449	WRITE ( 89 ) dsitransc
9450	ENDIF
9451	IF ( nsvfl > 0 ) THEN
9452	WRITE ( 89 ) svf
9453	WRITE ( 89 ) svfsurf
9454	ENDIF
9455	IF ( plant_canopy .AND. ncsfl > 0 ) THEN
9456	WRITE ( 89 ) csf
9457	WRITE ( 89 ) csfsurf
9458	ENDIF
9459	IF ( nmrtbl > 0 ) THEN
9460	WRITE ( 89 ) mrtsky
9461	WRITE ( 89 ) mrtskyt
9462	WRITE ( 89 ) mrtdsit
9463	ENDIF
9464	IF ( nmrtf > 0 ) THEN
9465	WRITE ( 89 ) mrtf
9466	WRITE ( 89 ) mrtft
9467	WRITE ( 89 ) mrtfsurf
9468	ENDIF
9469	!
9470	!-- Close binary file
9471	CALL close_file( 89 )
9472
9473	ENDIF
9474	#if defined( __parallel )
9475	CALL MPI_BARRIER( comm2d, ierr )
9476	#endif
9477	ENDDO
9478
9479	CALL location_message( 'writing view factors for radiation interaction', 'finished' )
9480
9481
9482	END SUBROUTINE radiation_write_svf
9483
9484
9485	!------------------------------------------------------------------------------!
9486	!
9487	! Description:
9488	! ------------
9489	!> Block of auxiliary subroutines for RTM:
9490	!> 1. quicksort and corresponding comparison
9491	!> 2. merge_and_grow_csf for implementation of "dynamical growing"
9492	!> array for csf
9493	!------------------------------------------------------------------------------!
9494	!-- quicksort.f --f90--
9495	!-- Author: t-nissie, adaptation J.Resler
9496	!-- License: GPLv3
9497	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9498	RECURSIVE SUBROUTINE quicksort_itarget(itarget, vffrac, ztransp, first, last)
9499	IMPLICIT NONE
9500	INTEGER(iwp), DIMENSION(:), INTENT(INOUT) :: itarget
9501	REAL(wp), DIMENSION(:), INTENT(INOUT) :: vffrac, ztransp
9502	INTEGER(iwp), INTENT(IN) :: first, last
9503	INTEGER(iwp) :: x, t
9504	INTEGER(iwp) :: i, j
9505	REAL(wp) :: tr
9506
9507	IF ( first>=last ) RETURN
9508	x = itarget((first+last)/2)
9509	i = first
9510	j = last
9511	DO
9512	DO WHILE ( itarget(i) < x )
9513	i=i+1
9514	ENDDO
9515	DO WHILE ( x < itarget(j) )
9516	j=j-1
9517	ENDDO
9518	IF ( i >= j ) EXIT
9519	t = itarget(i); itarget(i) = itarget(j); itarget(j) = t
9520	tr = vffrac(i); vffrac(i) = vffrac(j); vffrac(j) = tr
9521	tr = ztransp(i); ztransp(i) = ztransp(j); ztransp(j) = tr
9522	i=i+1
9523	j=j-1
9524	ENDDO
9525	IF ( first < i-1 ) CALL quicksort_itarget(itarget, vffrac, ztransp, first, i-1)
9526	IF ( j+1 < last ) CALL quicksort_itarget(itarget, vffrac, ztransp, j+1, last)
9527	END SUBROUTINE quicksort_itarget
9528
9529	PURE FUNCTION svf_lt(svf1,svf2) result (res)
9530	TYPE (t_svf), INTENT(in) :: svf1,svf2
9531	LOGICAL :: res
9532	IF ( svf1%isurflt < svf2%isurflt .OR. &
9533	(svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN
9534	res = .TRUE.
9535	ELSE
9536	res = .FALSE.
9537	ENDIF
9538	END FUNCTION svf_lt
9539
9540
9541	!-- quicksort.f --f90--
9542	!-- Author: t-nissie, adaptation J.Resler
9543	!-- License: GPLv3
9544	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9545	RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last)
9546	IMPLICIT NONE
9547	TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl
9548	INTEGER(iwp), INTENT(IN) :: first, last
9549	TYPE(t_svf) :: x, t
9550	INTEGER(iwp) :: i, j
9551
9552	IF ( first>=last ) RETURN
9553	x = svfl( (first+last) / 2 )
9554	i = first
9555	j = last
9556	DO
9557	DO while ( svf_lt(svfl(i),x) )
9558	i=i+1
9559	ENDDO
9560	DO while ( svf_lt(x,svfl(j)) )
9561	j=j-1
9562	ENDDO
9563	IF ( i >= j ) EXIT
9564	t = svfl(i); svfl(i) = svfl(j); svfl(j) = t
9565	i=i+1
9566	j=j-1
9567	ENDDO
9568	IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1)
9569	IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last)
9570	END SUBROUTINE quicksort_svf
9571
9572	PURE FUNCTION csf_lt(csf1,csf2) result (res)
9573	TYPE (t_csf), INTENT(in) :: csf1,csf2
9574	LOGICAL :: res
9575	IF ( csf1%ip < csf2%ip .OR. &
9576	(csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. &
9577	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. &
9578	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
9579	csf1%itz < csf2%itz) .OR. &
9580	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
9581	csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN
9582	res = .TRUE.
9583	ELSE
9584	res = .FALSE.
9585	ENDIF
9586	END FUNCTION csf_lt
9587
9588
9589	!-- quicksort.f --f90--
9590	!-- Author: t-nissie, adaptation J.Resler
9591	!-- License: GPLv3
9592	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9593	RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last)
9594	IMPLICIT NONE
9595	TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl
9596	INTEGER(iwp), INTENT(IN) :: first, last
9597	TYPE(t_csf) :: x, t
9598	INTEGER(iwp) :: i, j
9599
9600	IF ( first>=last ) RETURN
9601	x = csfl( (first+last)/2 )
9602	i = first
9603	j = last
9604	DO
9605	DO while ( csf_lt(csfl(i),x) )
9606	i=i+1
9607	ENDDO
9608	DO while ( csf_lt(x,csfl(j)) )
9609	j=j-1
9610	ENDDO
9611	IF ( i >= j ) EXIT
9612	t = csfl(i); csfl(i) = csfl(j); csfl(j) = t
9613	i=i+1
9614	j=j-1
9615	ENDDO
9616	IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1)
9617	IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last)
9618	END SUBROUTINE quicksort_csf
9619
9620
9621	!------------------------------------------------------------------------------!
9622	!
9623	! Description:
9624	! ------------
9625	!> Grows the CSF array in RTM exponentially when it is full. During that,
9626	!> the ray canopy sink factors with common source face and target plant canopy
9627	!> grid cell are merged together so that the size doesn't grow out of control.
9628	!------------------------------------------------------------------------------!
9629	SUBROUTINE merge_and_grow_csf(newsize)
9630	INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl
9631	!< or -1 to shrink to minimum
9632	INTEGER(iwp) :: iread, iwrite
9633	TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew
9634
9635
9636	IF ( newsize == -1 ) THEN
9637	!-- merge in-place
9638	acsfnew => acsf
9639	ELSE
9640	!-- allocate new array
9641	IF ( mcsf == 0 ) THEN
9642	ALLOCATE( acsf1(newsize) )
9643	acsfnew => acsf1
9644	ELSE
9645	ALLOCATE( acsf2(newsize) )
9646	acsfnew => acsf2
9647	ENDIF
9648	ENDIF
9649
9650	IF ( ncsfl >= 1 ) THEN
9651	!-- sort csf in place (quicksort)
9652	CALL quicksort_csf(acsf,1,ncsfl)
9653
9654	!-- while moving to a new array, aggregate canopy sink factor records with identical box & source
9655	acsfnew(1) = acsf(1)
9656	iwrite = 1
9657	DO iread = 2, ncsfl
9658	!-- here acsf(kcsf) already has values from acsf(icsf)
9659	IF ( acsfnew(iwrite)%itx == acsf(iread)%itx &
9660	.AND. acsfnew(iwrite)%ity == acsf(iread)%ity &
9661	.AND. acsfnew(iwrite)%itz == acsf(iread)%itz &
9662	.AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN
9663
9664	acsfnew(iwrite)%rcvf = acsfnew(iwrite)%rcvf + acsf(iread)%rcvf
9665	!-- advance reading index, keep writing index
9666	ELSE
9667	!-- not identical, just advance and copy
9668	iwrite = iwrite + 1
9669	acsfnew(iwrite) = acsf(iread)
9670	ENDIF
9671	ENDDO
9672	ncsfl = iwrite
9673	ENDIF
9674
9675	IF ( newsize == -1 ) THEN
9676	!-- allocate new array and copy shrinked data
9677	IF ( mcsf == 0 ) THEN
9678	ALLOCATE( acsf1(ncsfl) )
9679	acsf1(1:ncsfl) = acsf2(1:ncsfl)
9680	ELSE
9681	ALLOCATE( acsf2(ncsfl) )
9682	acsf2(1:ncsfl) = acsf1(1:ncsfl)
9683	ENDIF
9684	ENDIF
9685
9686	!-- deallocate old array
9687	IF ( mcsf == 0 ) THEN
9688	mcsf = 1
9689	acsf => acsf1
9690	DEALLOCATE( acsf2 )
9691	ELSE
9692	mcsf = 0
9693	acsf => acsf2
9694	DEALLOCATE( acsf1 )
9695	ENDIF
9696	ncsfla = newsize
9697
9698	IF ( debug_output ) THEN
9699	WRITE( debug_string, '(A,2I12)' ) 'Grow acsf2:', ncsfl, ncsfla
9700	CALL debug_message( debug_string, 'info' )
9701	ENDIF
9702
9703	END SUBROUTINE merge_and_grow_csf
9704
9705
9706	!-- quicksort.f --f90--
9707	!-- Author: t-nissie, adaptation J.Resler
9708	!-- License: GPLv3
9709	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9710	RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last)
9711	IMPLICIT NONE
9712	INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt
9713	REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt
9714	INTEGER(iwp), INTENT(IN) :: first, last
9715	REAL(wp), DIMENSION(ndcsf) :: t2
9716	INTEGER(iwp), DIMENSION(kdcsf) :: x, t1
9717	INTEGER(iwp) :: i, j
9718
9719	IF ( first>=last ) RETURN
9720	x = kpcsflt(:, (first+last)/2 )
9721	i = first
9722	j = last
9723	DO
9724	DO while ( csf_lt2(kpcsflt(:,i),x) )
9725	i=i+1
9726	ENDDO
9727	DO while ( csf_lt2(x,kpcsflt(:,j)) )
9728	j=j-1
9729	ENDDO
9730	IF ( i >= j ) EXIT
9731	t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1
9732	t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2
9733	i=i+1
9734	j=j-1
9735	ENDDO
9736	IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1)
9737	IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last)
9738	END SUBROUTINE quicksort_csf2
9739
9740
9741	PURE FUNCTION csf_lt2(item1, item2) result(res)
9742	INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2
9743	LOGICAL :: res
9744	res = ( (item1(3) < item2(3)) &
9745	.OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) &
9746	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) &
9747	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) &
9748	.AND. item1(4) < item2(4)) )
9749	END FUNCTION csf_lt2
9750
9751	PURE FUNCTION searchsorted(athresh, val) result(ind)
9752	REAL(wp), DIMENSION(:), INTENT(IN) :: athresh
9753	REAL(wp), INTENT(IN) :: val
9754	INTEGER(iwp) :: ind
9755	INTEGER(iwp) :: i
9756
9757	DO i = LBOUND(athresh, 1), UBOUND(athresh, 1)
9758	IF ( val < athresh(i) ) THEN
9759	ind = i - 1
9760	RETURN
9761	ENDIF
9762	ENDDO
9763	ind = UBOUND(athresh, 1)
9764	END FUNCTION searchsorted
9765
9766
9767	!------------------------------------------------------------------------------!
9768	!
9769	! Description:
9770	! ------------
9771	!> Subroutine for averaging 3D data
9772	!------------------------------------------------------------------------------!
9773	SUBROUTINE radiation_3d_data_averaging( mode, variable )
9774
9775
9776	USE control_parameters
9777
9778	USE indices
9779
9780	USE kinds
9781
9782	IMPLICIT NONE
9783
9784	CHARACTER (LEN=*) :: mode !<
9785	CHARACTER (LEN=*) :: variable !<
9786
9787	LOGICAL :: match_lsm !< flag indicating natural-type surface
9788	LOGICAL :: match_usm !< flag indicating urban-type surface
9789
9790	INTEGER(iwp) :: i !<
9791	INTEGER(iwp) :: j !<
9792	INTEGER(iwp) :: k !<
9793	INTEGER(iwp) :: l, m !< index of current surface element
9794
9795	INTEGER(iwp) :: ids, idsint_u, idsint_l, isurf
9796	CHARACTER(LEN=varnamelength) :: var
9797
9798	!-- find the real name of the variable
9799	ids = -1
9800	l = -1
9801	var = TRIM(variable)
9802	DO i = 0, nd-1
9803	k = len(TRIM(var))
9804	j = len(TRIM(dirname(i)))
9805	IF ( k-j+1 >= 1_iwp ) THEN
9806	IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN
9807	ids = i
9808	idsint_u = dirint_u(ids)
9809	idsint_l = dirint_l(ids)
9810	var = var(:k-j)
9811	EXIT
9812	ENDIF
9813	ENDIF
9814	ENDDO
9815	IF ( ids == -1 ) THEN
9816	var = TRIM(variable)
9817	ENDIF
9818
9819	IF ( mode == 'allocate' ) THEN
9820
9821	SELECT CASE ( TRIM( var ) )
9822	!-- block of large scale (e.g. RRTMG) radiation output variables
9823	CASE ( 'rad_net*' )
9824	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
9825	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
9826	ENDIF
9827	rad_net_av = 0.0_wp
9828
9829	CASE ( 'rad_lw_in*' )
9830	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
9831	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9832	ENDIF
9833	rad_lw_in_xy_av = 0.0_wp
9834
9835	CASE ( 'rad_lw_out*' )
9836	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
9837	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9838	ENDIF
9839	rad_lw_out_xy_av = 0.0_wp
9840
9841	CASE ( 'rad_sw_in*' )
9842	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
9843	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9844	ENDIF
9845	rad_sw_in_xy_av = 0.0_wp
9846
9847	CASE ( 'rad_sw_out*' )
9848	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
9849	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9850	ENDIF
9851	rad_sw_out_xy_av = 0.0_wp
9852
9853	CASE ( 'rad_lw_in' )
9854	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
9855	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9856	ENDIF
9857	rad_lw_in_av = 0.0_wp
9858
9859	CASE ( 'rad_lw_out' )
9860	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
9861	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9862	ENDIF
9863	rad_lw_out_av = 0.0_wp
9864
9865	CASE ( 'rad_lw_cs_hr' )
9866	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9867	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9868	ENDIF
9869	rad_lw_cs_hr_av = 0.0_wp
9870
9871	CASE ( 'rad_lw_hr' )
9872	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
9873	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9874	ENDIF
9875	rad_lw_hr_av = 0.0_wp
9876
9877	CASE ( 'rad_sw_in' )
9878	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
9879	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9880	ENDIF
9881	rad_sw_in_av = 0.0_wp
9882
9883	CASE ( 'rad_sw_out' )
9884	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
9885	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9886	ENDIF
9887	rad_sw_out_av = 0.0_wp
9888
9889	CASE ( 'rad_sw_cs_hr' )
9890	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9891	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9892	ENDIF
9893	rad_sw_cs_hr_av = 0.0_wp
9894
9895	CASE ( 'rad_sw_hr' )
9896	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
9897	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9898	ENDIF
9899	rad_sw_hr_av = 0.0_wp
9900
9901	!-- block of RTM output variables
9902	CASE ( 'rtm_rad_net' )
9903	!-- array of complete radiation balance
9904	IF ( .NOT. ALLOCATED(surfradnet_av) ) THEN
9905	ALLOCATE( surfradnet_av(nsurfl) )
9906	surfradnet_av = 0.0_wp
9907	ENDIF
9908
9909	CASE ( 'rtm_rad_insw' )
9910	!-- array of sw radiation falling to surface after i-th reflection
9911	IF ( .NOT. ALLOCATED(surfinsw_av) ) THEN
9912	ALLOCATE( surfinsw_av(nsurfl) )
9913	surfinsw_av = 0.0_wp
9914	ENDIF
9915
9916	CASE ( 'rtm_rad_inlw' )
9917	!-- array of lw radiation falling to surface after i-th reflection
9918	IF ( .NOT. ALLOCATED(surfinlw_av) ) THEN
9919	ALLOCATE( surfinlw_av(nsurfl) )
9920	surfinlw_av = 0.0_wp
9921	ENDIF
9922
9923	CASE ( 'rtm_rad_inswdir' )
9924	!-- array of direct sw radiation falling to surface from sun
9925	IF ( .NOT. ALLOCATED(surfinswdir_av) ) THEN
9926	ALLOCATE( surfinswdir_av(nsurfl) )
9927	surfinswdir_av = 0.0_wp
9928	ENDIF
9929
9930	CASE ( 'rtm_rad_inswdif' )
9931	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
9932	IF ( .NOT. ALLOCATED(surfinswdif_av) ) THEN
9933	ALLOCATE( surfinswdif_av(nsurfl) )
9934	surfinswdif_av = 0.0_wp
9935	ENDIF
9936
9937	CASE ( 'rtm_rad_inswref' )
9938	!-- array of sw radiation falling to surface from reflections
9939	IF ( .NOT. ALLOCATED(surfinswref_av) ) THEN
9940	ALLOCATE( surfinswref_av(nsurfl) )
9941	surfinswref_av = 0.0_wp
9942	ENDIF
9943
9944	CASE ( 'rtm_rad_inlwdif' )
9945	!-- array of sw radiation falling to surface after i-th reflection
9946	IF ( .NOT. ALLOCATED(surfinlwdif_av) ) THEN
9947	ALLOCATE( surfinlwdif_av(nsurfl) )
9948	surfinlwdif_av = 0.0_wp
9949	ENDIF
9950
9951	CASE ( 'rtm_rad_inlwref' )
9952	!-- array of lw radiation falling to surface from reflections
9953	IF ( .NOT. ALLOCATED(surfinlwref_av) ) THEN
9954	ALLOCATE( surfinlwref_av(nsurfl) )
9955	surfinlwref_av = 0.0_wp
9956	ENDIF
9957
9958	CASE ( 'rtm_rad_outsw' )
9959	!-- array of sw radiation emitted from surface after i-th reflection
9960	IF ( .NOT. ALLOCATED(surfoutsw_av) ) THEN
9961	ALLOCATE( surfoutsw_av(nsurfl) )
9962	surfoutsw_av = 0.0_wp
9963	ENDIF
9964
9965	CASE ( 'rtm_rad_outlw' )
9966	!-- array of lw radiation emitted from surface after i-th reflection
9967	IF ( .NOT. ALLOCATED(surfoutlw_av) ) THEN
9968	ALLOCATE( surfoutlw_av(nsurfl) )
9969	surfoutlw_av = 0.0_wp
9970	ENDIF
9971	CASE ( 'rtm_rad_ressw' )
9972	!-- array of residua of sw radiation absorbed in surface after last reflection
9973	IF ( .NOT. ALLOCATED(surfins_av) ) THEN
9974	ALLOCATE( surfins_av(nsurfl) )
9975	surfins_av = 0.0_wp
9976	ENDIF
9977
9978	CASE ( 'rtm_rad_reslw' )
9979	!-- array of residua of lw radiation absorbed in surface after last reflection
9980	IF ( .NOT. ALLOCATED(surfinl_av) ) THEN
9981	ALLOCATE( surfinl_av(nsurfl) )
9982	surfinl_av = 0.0_wp
9983	ENDIF
9984
9985	CASE ( 'rtm_rad_pc_inlw' )
9986	!-- array of of lw radiation absorbed in plant canopy
9987	IF ( .NOT. ALLOCATED(pcbinlw_av) ) THEN
9988	ALLOCATE( pcbinlw_av(1:npcbl) )
9989	pcbinlw_av = 0.0_wp
9990	ENDIF
9991
9992	CASE ( 'rtm_rad_pc_insw' )
9993	!-- array of of sw radiation absorbed in plant canopy
9994	IF ( .NOT. ALLOCATED(pcbinsw_av) ) THEN
9995	ALLOCATE( pcbinsw_av(1:npcbl) )
9996	pcbinsw_av = 0.0_wp
9997	ENDIF
9998
9999	CASE ( 'rtm_rad_pc_inswdir' )
10000	!-- array of of direct sw radiation absorbed in plant canopy
10001	IF ( .NOT. ALLOCATED(pcbinswdir_av) ) THEN
10002	ALLOCATE( pcbinswdir_av(1:npcbl) )
10003	pcbinswdir_av = 0.0_wp
10004	ENDIF
10005
10006	CASE ( 'rtm_rad_pc_inswdif' )
10007	!-- array of of diffuse sw radiation absorbed in plant canopy
10008	IF ( .NOT. ALLOCATED(pcbinswdif_av) ) THEN
10009	ALLOCATE( pcbinswdif_av(1:npcbl) )
10010	pcbinswdif_av = 0.0_wp
10011	ENDIF
10012
10013	CASE ( 'rtm_rad_pc_inswref' )
10014	!-- array of of reflected sw radiation absorbed in plant canopy
10015	IF ( .NOT. ALLOCATED(pcbinswref_av) ) THEN
10016	ALLOCATE( pcbinswref_av(1:npcbl) )
10017	pcbinswref_av = 0.0_wp
10018	ENDIF
10019
10020	CASE ( 'rtm_mrt_sw' )
10021	IF ( .NOT. ALLOCATED( mrtinsw_av ) ) THEN
10022	ALLOCATE( mrtinsw_av(nmrtbl) )
10023	ENDIF
10024	mrtinsw_av = 0.0_wp
10025
10026	CASE ( 'rtm_mrt_lw' )
10027	IF ( .NOT. ALLOCATED( mrtinlw_av ) ) THEN
10028	ALLOCATE( mrtinlw_av(nmrtbl) )
10029	ENDIF
10030	mrtinlw_av = 0.0_wp
10031
10032	CASE ( 'rtm_mrt' )
10033	IF ( .NOT. ALLOCATED( mrt_av ) ) THEN
10034	ALLOCATE( mrt_av(nmrtbl) )
10035	ENDIF
10036	mrt_av = 0.0_wp
10037
10038	CASE DEFAULT
10039	CONTINUE
10040
10041	END SELECT
10042
10043	ELSEIF ( mode == 'sum' ) THEN
10044
10045	SELECT CASE ( TRIM( var ) )
10046	!-- block of large scale (e.g. RRTMG) radiation output variables
10047	CASE ( 'rad_net*' )
10048	IF ( ALLOCATED( rad_net_av ) ) THEN
10049	DO i = nxl, nxr
10050	DO j = nys, nyn
10051	match_lsm = surf_lsm_h%start_index(j,i) <= &
10052	surf_lsm_h%end_index(j,i)
10053	match_usm = surf_usm_h%start_index(j,i) <= &
10054	surf_usm_h%end_index(j,i)
10055
10056	IF ( match_lsm .AND. .NOT. match_usm ) THEN
10057	m = surf_lsm_h%end_index(j,i)
10058	rad_net_av(j,i) = rad_net_av(j,i) + &
10059	surf_lsm_h%rad_net(m)
10060	ELSEIF ( match_usm ) THEN
10061	m = surf_usm_h%end_index(j,i)
10062	rad_net_av(j,i) = rad_net_av(j,i) + &
10063	surf_usm_h%rad_net(m)
10064	ENDIF
10065	ENDDO
10066	ENDDO
10067	ENDIF
10068
10069	CASE ( 'rad_lw_in*' )
10070	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
10071	DO i = nxl, nxr
10072	DO j = nys, nyn
10073	match_lsm = surf_lsm_h%start_index(j,i) <= &
10074	surf_lsm_h%end_index(j,i)
10075	match_usm = surf_usm_h%start_index(j,i) <= &
10076	surf_usm_h%end_index(j,i)
10077
10078	IF ( match_lsm .AND. .NOT. match_usm ) THEN
10079	m = surf_lsm_h%end_index(j,i)
10080	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + &
10081	surf_lsm_h%rad_lw_in(m)
10082	ELSEIF ( match_usm ) THEN
10083	m = surf_usm_h%end_index(j,i)
10084	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + &
10085	surf_usm_h%rad_lw_in(m)
10086	ENDIF
10087	ENDDO
10088	ENDDO
10089	ENDIF
10090
10091	CASE ( 'rad_lw_out*' )
10092	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
10093	DO i = nxl, nxr
10094	DO j = nys, nyn
10095	match_lsm = surf_lsm_h%start_index(j,i) <= &
10096	surf_lsm_h%end_index(j,i)
10097	match_usm = surf_usm_h%start_index(j,i) <= &
10098	surf_usm_h%end_index(j,i)
10099
10100	IF ( match_lsm .AND. .NOT. match_usm ) THEN
10101	m = surf_lsm_h%end_index(j,i)
10102	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + &
10103	surf_lsm_h%rad_lw_out(m)
10104	ELSEIF ( match_usm ) THEN
10105	m = surf_usm_h%end_index(j,i)
10106	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + &
10107	surf_usm_h%rad_lw_out(m)
10108	ENDIF
10109	ENDDO
10110	ENDDO
10111	ENDIF
10112
10113	CASE ( 'rad_sw_in*' )
10114	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
10115	DO i = nxl, nxr
10116	DO j = nys, nyn
10117	match_lsm = surf_lsm_h%start_index(j,i) <= &
10118	surf_lsm_h%end_index(j,i)
10119	match_usm = surf_usm_h%start_index(j,i) <= &
10120	surf_usm_h%end_index(j,i)
10121
10122	IF ( match_lsm .AND. .NOT. match_usm ) THEN
10123	m = surf_lsm_h%end_index(j,i)
10124	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + &
10125	surf_lsm_h%rad_sw_in(m)
10126	ELSEIF ( match_usm ) THEN
10127	m = surf_usm_h%end_index(j,i)
10128	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + &
10129	surf_usm_h%rad_sw_in(m)
10130	ENDIF
10131	ENDDO
10132	ENDDO
10133	ENDIF
10134
10135	CASE ( 'rad_sw_out*' )
10136	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
10137	DO i = nxl, nxr
10138	DO j = nys, nyn
10139	match_lsm = surf_lsm_h%start_index(j,i) <= &
10140	surf_lsm_h%end_index(j,i)
10141	match_usm = surf_usm_h%start_index(j,i) <= &
10142	surf_usm_h%end_index(j,i)
10143
10144	IF ( match_lsm .AND. .NOT. match_usm ) THEN
10145	m = surf_lsm_h%end_index(j,i)
10146	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + &
10147	surf_lsm_h%rad_sw_out(m)
10148	ELSEIF ( match_usm ) THEN
10149	m = surf_usm_h%end_index(j,i)
10150	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + &
10151	surf_usm_h%rad_sw_out(m)
10152	ENDIF
10153	ENDDO
10154	ENDDO
10155	ENDIF
10156
10157	CASE ( 'rad_lw_in' )
10158	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
10159	DO i = nxlg, nxrg
10160	DO j = nysg, nyng
10161	DO k = nzb, nzt+1
10162	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
10163	+ rad_lw_in(k,j,i)
10164	ENDDO
10165	ENDDO
10166	ENDDO
10167	ENDIF
10168
10169	CASE ( 'rad_lw_out' )
10170	IF ( ALLOCATED( rad_lw_out_av ) ) THEN
10171	DO i = nxlg, nxrg
10172	DO j = nysg, nyng
10173	DO k = nzb, nzt+1
10174	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
10175	+ rad_lw_out(k,j,i)
10176	ENDDO
10177	ENDDO
10178	ENDDO
10179	ENDIF
10180
10181	CASE ( 'rad_lw_cs_hr' )
10182	IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10183	DO i = nxlg, nxrg
10184	DO j = nysg, nyng
10185	DO k = nzb, nzt+1
10186	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
10187	+ rad_lw_cs_hr(k,j,i)
10188	ENDDO
10189	ENDDO
10190	ENDDO
10191	ENDIF
10192
10193	CASE ( 'rad_lw_hr' )
10194	IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
10195	DO i = nxlg, nxrg
10196	DO j = nysg, nyng
10197	DO k = nzb, nzt+1
10198	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
10199	+ rad_lw_hr(k,j,i)
10200	ENDDO
10201	ENDDO
10202	ENDDO
10203	ENDIF
10204
10205	CASE ( 'rad_sw_in' )
10206	IF ( ALLOCATED( rad_sw_in_av ) ) THEN
10207	DO i = nxlg, nxrg
10208	DO j = nysg, nyng
10209	DO k = nzb, nzt+1
10210	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
10211	+ rad_sw_in(k,j,i)
10212	ENDDO
10213	ENDDO
10214	ENDDO
10215	ENDIF
10216
10217	CASE ( 'rad_sw_out' )
10218	IF ( ALLOCATED( rad_sw_out_av ) ) THEN
10219	DO i = nxlg, nxrg
10220	DO j = nysg, nyng
10221	DO k = nzb, nzt+1
10222	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
10223	+ rad_sw_out(k,j,i)
10224	ENDDO
10225	ENDDO
10226	ENDDO
10227	ENDIF
10228
10229	CASE ( 'rad_sw_cs_hr' )
10230	IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10231	DO i = nxlg, nxrg
10232	DO j = nysg, nyng
10233	DO k = nzb, nzt+1
10234	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
10235	+ rad_sw_cs_hr(k,j,i)
10236	ENDDO
10237	ENDDO
10238	ENDDO
10239	ENDIF
10240
10241	CASE ( 'rad_sw_hr' )
10242	IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
10243	DO i = nxlg, nxrg
10244	DO j = nysg, nyng
10245	DO k = nzb, nzt+1
10246	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
10247	+ rad_sw_hr(k,j,i)
10248	ENDDO
10249	ENDDO
10250	ENDDO
10251	ENDIF
10252
10253	!-- block of RTM output variables
10254	CASE ( 'rtm_rad_net' )
10255	!-- array of complete radiation balance
10256	DO isurf = dirstart(ids), dirend(ids)
10257	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10258	surfradnet_av(isurf) = surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)
10259	ENDIF
10260	ENDDO
10261
10262	CASE ( 'rtm_rad_insw' )
10263	!-- array of sw radiation falling to surface after i-th reflection
10264	DO isurf = dirstart(ids), dirend(ids)
10265	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10266	surfinsw_av(isurf) = surfinsw_av(isurf) + surfinsw(isurf)
10267	ENDIF
10268	ENDDO
10269
10270	CASE ( 'rtm_rad_inlw' )
10271	!-- array of lw radiation falling to surface after i-th reflection
10272	DO isurf = dirstart(ids), dirend(ids)
10273	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10274	surfinlw_av(isurf) = surfinlw_av(isurf) + surfinlw(isurf)
10275	ENDIF
10276	ENDDO
10277
10278	CASE ( 'rtm_rad_inswdir' )
10279	!-- array of direct sw radiation falling to surface from sun
10280	DO isurf = dirstart(ids), dirend(ids)
10281	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10282	surfinswdir_av(isurf) = surfinswdir_av(isurf) + surfinswdir(isurf)
10283	ENDIF
10284	ENDDO
10285
10286	CASE ( 'rtm_rad_inswdif' )
10287	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
10288	DO isurf = dirstart(ids), dirend(ids)
10289	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10290	surfinswdif_av(isurf) = surfinswdif_av(isurf) + surfinswdif(isurf)
10291	ENDIF
10292	ENDDO
10293
10294	CASE ( 'rtm_rad_inswref' )
10295	!-- array of sw radiation falling to surface from reflections
10296	DO isurf = dirstart(ids), dirend(ids)
10297	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10298	surfinswref_av(isurf) = surfinswref_av(isurf) + surfinsw(isurf) - &
10299	surfinswdir(isurf) - surfinswdif(isurf)
10300	ENDIF
10301	ENDDO
10302
10303
10304	CASE ( 'rtm_rad_inlwdif' )
10305	!-- array of sw radiation falling to surface after i-th reflection
10306	DO isurf = dirstart(ids), dirend(ids)
10307	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10308	surfinlwdif_av(isurf) = surfinlwdif_av(isurf) + surfinlwdif(isurf)
10309	ENDIF
10310	ENDDO
10311	!
10312	CASE ( 'rtm_rad_inlwref' )
10313	!-- array of lw radiation falling to surface from reflections
10314	DO isurf = dirstart(ids), dirend(ids)
10315	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10316	surfinlwref_av(isurf) = surfinlwref_av(isurf) + &
10317	surfinlw(isurf) - surfinlwdif(isurf)
10318	ENDIF
10319	ENDDO
10320
10321	CASE ( 'rtm_rad_outsw' )
10322	!-- array of sw radiation emitted from surface after i-th reflection
10323	DO isurf = dirstart(ids), dirend(ids)
10324	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10325	surfoutsw_av(isurf) = surfoutsw_av(isurf) + surfoutsw(isurf)
10326	ENDIF
10327	ENDDO
10328
10329	CASE ( 'rtm_rad_outlw' )
10330	!-- array of lw radiation emitted from surface after i-th reflection
10331	DO isurf = dirstart(ids), dirend(ids)
10332	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10333	surfoutlw_av(isurf) = surfoutlw_av(isurf) + surfoutlw(isurf)
10334	ENDIF
10335	ENDDO
10336
10337	CASE ( 'rtm_rad_ressw' )
10338	!-- array of residua of sw radiation absorbed in surface after last reflection
10339	DO isurf = dirstart(ids), dirend(ids)
10340	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10341	surfins_av(isurf) = surfins_av(isurf) + surfins(isurf)
10342	ENDIF
10343	ENDDO
10344
10345	CASE ( 'rtm_rad_reslw' )
10346	!-- array of residua of lw radiation absorbed in surface after last reflection
10347	DO isurf = dirstart(ids), dirend(ids)
10348	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10349	surfinl_av(isurf) = surfinl_av(isurf) + surfinl(isurf)
10350	ENDIF
10351	ENDDO
10352
10353	CASE ( 'rtm_rad_pc_inlw' )
10354	DO l = 1, npcbl
10355	pcbinlw_av(l) = pcbinlw_av(l) + pcbinlw(l)
10356	ENDDO
10357
10358	CASE ( 'rtm_rad_pc_insw' )
10359	DO l = 1, npcbl
10360	pcbinsw_av(l) = pcbinsw_av(l) + pcbinsw(l)
10361	ENDDO
10362
10363	CASE ( 'rtm_rad_pc_inswdir' )
10364	DO l = 1, npcbl
10365	pcbinswdir_av(l) = pcbinswdir_av(l) + pcbinswdir(l)
10366	ENDDO
10367
10368	CASE ( 'rtm_rad_pc_inswdif' )
10369	DO l = 1, npcbl
10370	pcbinswdif_av(l) = pcbinswdif_av(l) + pcbinswdif(l)
10371	ENDDO
10372
10373	CASE ( 'rtm_rad_pc_inswref' )
10374	DO l = 1, npcbl
10375	pcbinswref_av(l) = pcbinswref_av(l) + pcbinsw(l) - pcbinswdir(l) - pcbinswdif(l)
10376	ENDDO
10377
10378	CASE ( 'rad_mrt_sw' )
10379	IF ( ALLOCATED( mrtinsw_av ) ) THEN
10380	mrtinsw_av(:) = mrtinsw_av(:) + mrtinsw(:)
10381	ENDIF
10382
10383	CASE ( 'rad_mrt_lw' )
10384	IF ( ALLOCATED( mrtinlw_av ) ) THEN
10385	mrtinlw_av(:) = mrtinlw_av(:) + mrtinlw(:)
10386	ENDIF
10387
10388	CASE ( 'rad_mrt' )
10389	IF ( ALLOCATED( mrt_av ) ) THEN
10390	mrt_av(:) = mrt_av(:) + mrt(:)
10391	ENDIF
10392
10393	CASE DEFAULT
10394	CONTINUE
10395
10396	END SELECT
10397
10398	ELSEIF ( mode == 'average' ) THEN
10399
10400	SELECT CASE ( TRIM( var ) )
10401	!-- block of large scale (e.g. RRTMG) radiation output variables
10402	CASE ( 'rad_net*' )
10403	IF ( ALLOCATED( rad_net_av ) ) THEN
10404	DO i = nxlg, nxrg
10405	DO j = nysg, nyng
10406	rad_net_av(j,i) = rad_net_av(j,i) &
10407	/ REAL( average_count_3d, KIND=wp )
10408	ENDDO
10409	ENDDO
10410	ENDIF
10411
10412	CASE ( 'rad_lw_in*' )
10413	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
10414	DO i = nxlg, nxrg
10415	DO j = nysg, nyng
10416	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) &
10417	/ REAL( average_count_3d, KIND=wp )
10418	ENDDO
10419	ENDDO
10420	ENDIF
10421
10422	CASE ( 'rad_lw_out*' )
10423	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
10424	DO i = nxlg, nxrg
10425	DO j = nysg, nyng
10426	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) &
10427	/ REAL( average_count_3d, KIND=wp )
10428	ENDDO
10429	ENDDO
10430	ENDIF
10431
10432	CASE ( 'rad_sw_in*' )
10433	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
10434	DO i = nxlg, nxrg
10435	DO j = nysg, nyng
10436	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) &
10437	/ REAL( average_count_3d, KIND=wp )
10438	ENDDO
10439	ENDDO
10440	ENDIF
10441
10442	CASE ( 'rad_sw_out*' )
10443	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
10444	DO i = nxlg, nxrg
10445	DO j = nysg, nyng
10446	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) &
10447	/ REAL( average_count_3d, KIND=wp )
10448	ENDDO
10449	ENDDO
10450	ENDIF
10451
10452	CASE ( 'rad_lw_in' )
10453	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
10454	DO i = nxlg, nxrg
10455	DO j = nysg, nyng
10456	DO k = nzb, nzt+1
10457	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
10458	/ REAL( average_count_3d, KIND=wp )
10459	ENDDO
10460	ENDDO
10461	ENDDO
10462	ENDIF
10463
10464	CASE ( 'rad_lw_out' )
10465	IF ( ALLOCATED( rad_lw_out_av ) ) THEN
10466	DO i = nxlg, nxrg
10467	DO j = nysg, nyng
10468	DO k = nzb, nzt+1
10469	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
10470	/ REAL( average_count_3d, KIND=wp )
10471	ENDDO
10472	ENDDO
10473	ENDDO
10474	ENDIF
10475
10476	CASE ( 'rad_lw_cs_hr' )
10477	IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10478	DO i = nxlg, nxrg
10479	DO j = nysg, nyng
10480	DO k = nzb, nzt+1
10481	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
10482	/ REAL( average_count_3d, KIND=wp )
10483	ENDDO
10484	ENDDO
10485	ENDDO
10486	ENDIF
10487
10488	CASE ( 'rad_lw_hr' )
10489	IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
10490	DO i = nxlg, nxrg
10491	DO j = nysg, nyng
10492	DO k = nzb, nzt+1
10493	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
10494	/ REAL( average_count_3d, KIND=wp )
10495	ENDDO
10496	ENDDO
10497	ENDDO
10498	ENDIF
10499
10500	CASE ( 'rad_sw_in' )
10501	IF ( ALLOCATED( rad_sw_in_av ) ) THEN
10502	DO i = nxlg, nxrg
10503	DO j = nysg, nyng
10504	DO k = nzb, nzt+1
10505	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
10506	/ REAL( average_count_3d, KIND=wp )
10507	ENDDO
10508	ENDDO
10509	ENDDO
10510	ENDIF
10511
10512	CASE ( 'rad_sw_out' )
10513	IF ( ALLOCATED( rad_sw_out_av ) ) THEN
10514	DO i = nxlg, nxrg
10515	DO j = nysg, nyng
10516	DO k = nzb, nzt+1
10517	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
10518	/ REAL( average_count_3d, KIND=wp )
10519	ENDDO
10520	ENDDO
10521	ENDDO
10522	ENDIF
10523
10524	CASE ( 'rad_sw_cs_hr' )
10525	IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10526	DO i = nxlg, nxrg
10527	DO j = nysg, nyng
10528	DO k = nzb, nzt+1
10529	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
10530	/ REAL( average_count_3d, KIND=wp )
10531	ENDDO
10532	ENDDO
10533	ENDDO
10534	ENDIF
10535
10536	CASE ( 'rad_sw_hr' )
10537	IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
10538	DO i = nxlg, nxrg
10539	DO j = nysg, nyng
10540	DO k = nzb, nzt+1
10541	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
10542	/ REAL( average_count_3d, KIND=wp )
10543	ENDDO
10544	ENDDO
10545	ENDDO
10546	ENDIF
10547
10548	!-- block of RTM output variables
10549	CASE ( 'rtm_rad_net' )
10550	!-- array of complete radiation balance
10551	DO isurf = dirstart(ids), dirend(ids)
10552	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10553	surfradnet_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
10554	ENDIF
10555	ENDDO
10556
10557	CASE ( 'rtm_rad_insw' )
10558	!-- array of sw radiation falling to surface after i-th reflection
10559	DO isurf = dirstart(ids), dirend(ids)
10560	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10561	surfinsw_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
10562	ENDIF
10563	ENDDO
10564
10565	CASE ( 'rtm_rad_inlw' )
10566	!-- array of lw radiation falling to surface after i-th reflection
10567	DO isurf = dirstart(ids), dirend(ids)
10568	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10569	surfinlw_av(isurf) = surfinlw_av(isurf) / REAL( average_count_3d, kind=wp )
10570	ENDIF
10571	ENDDO
10572
10573	CASE ( 'rtm_rad_inswdir' )
10574	!-- array of direct sw radiation falling to surface from sun
10575	DO isurf = dirstart(ids), dirend(ids)
10576	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10577	surfinswdir_av(isurf) = surfinswdir_av(isurf) / REAL( average_count_3d, kind=wp )
10578	ENDIF
10579	ENDDO
10580
10581	CASE ( 'rtm_rad_inswdif' )
10582	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
10583	DO isurf = dirstart(ids), dirend(ids)
10584	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10585	surfinswdif_av(isurf) = surfinswdif_av(isurf) / REAL( average_count_3d, kind=wp )
10586	ENDIF
10587	ENDDO
10588
10589	CASE ( 'rtm_rad_inswref' )
10590	!-- array of sw radiation falling to surface from reflections
10591	DO isurf = dirstart(ids), dirend(ids)
10592	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10593	surfinswref_av(isurf) = surfinswref_av(isurf) / REAL( average_count_3d, kind=wp )
10594	ENDIF
10595	ENDDO
10596
10597	CASE ( 'rtm_rad_inlwdif' )
10598	!-- array of sw radiation falling to surface after i-th reflection
10599	DO isurf = dirstart(ids), dirend(ids)
10600	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10601	surfinlwdif_av(isurf) = surfinlwdif_av(isurf) / REAL( average_count_3d, kind=wp )
10602	ENDIF
10603	ENDDO
10604
10605	CASE ( 'rtm_rad_inlwref' )
10606	!-- array of lw radiation falling to surface from reflections
10607	DO isurf = dirstart(ids), dirend(ids)
10608	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10609	surfinlwref_av(isurf) = surfinlwref_av(isurf) / REAL( average_count_3d, kind=wp )
10610	ENDIF
10611	ENDDO
10612
10613	CASE ( 'rtm_rad_outsw' )
10614	!-- array of sw radiation emitted from surface after i-th reflection
10615	DO isurf = dirstart(ids), dirend(ids)
10616	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10617	surfoutsw_av(isurf) = surfoutsw_av(isurf) / REAL( average_count_3d, kind=wp )
10618	ENDIF
10619	ENDDO
10620
10621	CASE ( 'rtm_rad_outlw' )
10622	!-- array of lw radiation emitted from surface after i-th reflection
10623	DO isurf = dirstart(ids), dirend(ids)
10624	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10625	surfoutlw_av(isurf) = surfoutlw_av(isurf) / REAL( average_count_3d, kind=wp )
10626	ENDIF
10627	ENDDO
10628
10629	CASE ( 'rtm_rad_ressw' )
10630	!-- array of residua of sw radiation absorbed in surface after last reflection
10631	DO isurf = dirstart(ids), dirend(ids)
10632	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10633	surfins_av(isurf) = surfins_av(isurf) / REAL( average_count_3d, kind=wp )
10634	ENDIF
10635	ENDDO
10636
10637	CASE ( 'rtm_rad_reslw' )
10638	!-- array of residua of lw radiation absorbed in surface after last reflection
10639	DO isurf = dirstart(ids), dirend(ids)
10640	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10641	surfinl_av(isurf) = surfinl_av(isurf) / REAL( average_count_3d, kind=wp )
10642	ENDIF
10643	ENDDO
10644
10645	CASE ( 'rtm_rad_pc_inlw' )
10646	DO l = 1, npcbl
10647	pcbinlw_av(:) = pcbinlw_av(:) / REAL( average_count_3d, kind=wp )
10648	ENDDO
10649
10650	CASE ( 'rtm_rad_pc_insw' )
10651	DO l = 1, npcbl
10652	pcbinsw_av(:) = pcbinsw_av(:) / REAL( average_count_3d, kind=wp )
10653	ENDDO
10654
10655	CASE ( 'rtm_rad_pc_inswdir' )
10656	DO l = 1, npcbl
10657	pcbinswdir_av(:) = pcbinswdir_av(:) / REAL( average_count_3d, kind=wp )
10658	ENDDO
10659
10660	CASE ( 'rtm_rad_pc_inswdif' )
10661	DO l = 1, npcbl
10662	pcbinswdif_av(:) = pcbinswdif_av(:) / REAL( average_count_3d, kind=wp )
10663	ENDDO
10664
10665	CASE ( 'rtm_rad_pc_inswref' )
10666	DO l = 1, npcbl
10667	pcbinswref_av(:) = pcbinswref_av(:) / REAL( average_count_3d, kind=wp )
10668	ENDDO
10669
10670	CASE ( 'rad_mrt_lw' )
10671	IF ( ALLOCATED( mrtinlw_av ) ) THEN
10672	mrtinlw_av(:) = mrtinlw_av(:) / REAL( average_count_3d, KIND=wp )
10673	ENDIF
10674
10675	CASE ( 'rad_mrt' )
10676	IF ( ALLOCATED( mrt_av ) ) THEN
10677	mrt_av(:) = mrt_av(:) / REAL( average_count_3d, KIND=wp )
10678	ENDIF
10679
10680	END SELECT
10681
10682	ENDIF
10683
10684	END SUBROUTINE radiation_3d_data_averaging
10685
10686
10687	!------------------------------------------------------------------------------!
10688	!
10689	! Description:
10690	! ------------
10691	!> Subroutine defining appropriate grid for netcdf variables.
10692	!> It is called out from subroutine netcdf.
10693	!------------------------------------------------------------------------------!
10694	SUBROUTINE radiation_define_netcdf_grid( variable, found, grid_x, grid_y, grid_z )
10695
10696	IMPLICIT NONE
10697
10698	CHARACTER (LEN=*), INTENT(IN) :: variable !<
10699	LOGICAL, INTENT(OUT) :: found !<
10700	CHARACTER (LEN=*), INTENT(OUT) :: grid_x !<
10701	CHARACTER (LEN=*), INTENT(OUT) :: grid_y !<
10702	CHARACTER (LEN=*), INTENT(OUT) :: grid_z !<
10703
10704	CHARACTER (len=varnamelength) :: var
10705
10706	found = .TRUE.
10707
10708	!
10709	!-- Check for the grid
10710	var = TRIM(variable)
10711	!-- RTM directional variables
10712	IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. &
10713	var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. &
10714	var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. &
10715	var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. &
10716	var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. &
10717	var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' .OR. &
10718	var == 'rtm_rad_pc_inlw' .OR. &
10719	var == 'rtm_rad_pc_insw' .OR. var == 'rtm_rad_pc_inswdir' .OR. &
10720	var == 'rtm_rad_pc_inswdif' .OR. var == 'rtm_rad_pc_inswref' .OR. &
10721	var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. &
10722	var(1:9) == 'rtm_skyvf' .OR. var(1:10) == 'rtm_skyvft' .OR. &
10723	var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' .OR. &
10724	var == 'rtm_mrt' .OR. var == 'rtm_mrt_sw' .OR. var == 'rtm_mrt_lw' ) THEN
10725
10726	found = .TRUE.
10727	grid_x = 'x'
10728	grid_y = 'y'
10729	grid_z = 'zu'
10730	ELSE
10731
10732	SELECT CASE ( TRIM( var ) )
10733
10734	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr', &
10735	'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', &
10736	'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz', &
10737	'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz', &
10738	'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz', &
10739	'rad_mrt', 'rad_mrt_sw', 'rad_mrt_lw' )
10740	grid_x = 'x'
10741	grid_y = 'y'
10742	grid_z = 'zu'
10743
10744	CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out', &
10745	'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', &
10746	'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', &
10747	'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' )
10748	grid_x = 'x'
10749	grid_y = 'y'
10750	grid_z = 'zw'
10751
10752
10753	CASE DEFAULT
10754	found = .FALSE.
10755	grid_x = 'none'
10756	grid_y = 'none'
10757	grid_z = 'none'
10758
10759	END SELECT
10760	ENDIF
10761
10762	END SUBROUTINE radiation_define_netcdf_grid
10763
10764	!------------------------------------------------------------------------------!
10765	!
10766	! Description:
10767	! ------------
10768	!> Subroutine defining 2D output variables
10769	!------------------------------------------------------------------------------!
10770	SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode, &
10771	local_pf, two_d, nzb_do, nzt_do )
10772
10773	USE indices
10774
10775	USE kinds
10776
10777
10778	IMPLICIT NONE
10779
10780	CHARACTER (LEN=*) :: grid !<
10781	CHARACTER (LEN=*) :: mode !<
10782	CHARACTER (LEN=*) :: variable !<
10783
10784	INTEGER(iwp) :: av !<
10785	INTEGER(iwp) :: i !<
10786	INTEGER(iwp) :: j !<
10787	INTEGER(iwp) :: k !<
10788	INTEGER(iwp) :: m !< index of surface element at grid point (j,i)
10789	INTEGER(iwp) :: nzb_do !<
10790	INTEGER(iwp) :: nzt_do !<
10791
10792	LOGICAL :: found !<
10793	LOGICAL :: two_d !< flag parameter that indicates 2D variables (horizontal cross sections)
10794
10795	REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute
10796
10797	REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !<
10798
10799	found = .TRUE.
10800
10801	SELECT CASE ( TRIM( variable ) )
10802
10803	CASE ( 'rad_net*_xy' ) ! 2d-array
10804	IF ( av == 0 ) THEN
10805	DO i = nxl, nxr
10806	DO j = nys, nyn
10807	!
10808	!-- Obtain rad_net from its respective surface type
10809	!-- Natural-type surfaces
10810	DO m = surf_lsm_h%start_index(j,i), &
10811	surf_lsm_h%end_index(j,i)
10812	local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m)
10813	ENDDO
10814	!
10815	!-- Urban-type surfaces
10816	DO m = surf_usm_h%start_index(j,i), &
10817	surf_usm_h%end_index(j,i)
10818	local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m)
10819	ENDDO
10820	ENDDO
10821	ENDDO
10822	ELSE
10823	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
10824	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
10825	rad_net_av = REAL( fill_value, KIND = wp )
10826	ENDIF
10827	DO i = nxl, nxr
10828	DO j = nys, nyn
10829	local_pf(i,j,nzb+1) = rad_net_av(j,i)
10830	ENDDO
10831	ENDDO
10832	ENDIF
10833	two_d = .TRUE.
10834	grid = 'zu1'
10835
10836	CASE ( 'rad_lw_in*_xy' ) ! 2d-array
10837	IF ( av == 0 ) THEN
10838	DO i = nxl, nxr
10839	DO j = nys, nyn
10840	!
10841	!-- Obtain rad_net from its respective surface type
10842	!-- Natural-type surfaces
10843	DO m = surf_lsm_h%start_index(j,i), &
10844	surf_lsm_h%end_index(j,i)
10845	local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_in(m)
10846	ENDDO
10847	!
10848	!-- Urban-type surfaces
10849	DO m = surf_usm_h%start_index(j,i), &
10850	surf_usm_h%end_index(j,i)
10851	local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_in(m)
10852	ENDDO
10853	ENDDO
10854	ENDDO
10855	ELSE
10856	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
10857	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10858	rad_lw_in_xy_av = REAL( fill_value, KIND = wp )
10859	ENDIF
10860	DO i = nxl, nxr
10861	DO j = nys, nyn
10862	local_pf(i,j,nzb+1) = rad_lw_in_xy_av(j,i)
10863	ENDDO
10864	ENDDO
10865	ENDIF
10866	two_d = .TRUE.
10867	grid = 'zu1'
10868
10869	CASE ( 'rad_lw_out*_xy' ) ! 2d-array
10870	IF ( av == 0 ) THEN
10871	DO i = nxl, nxr
10872	DO j = nys, nyn
10873	!
10874	!-- Obtain rad_net from its respective surface type
10875	!-- Natural-type surfaces
10876	DO m = surf_lsm_h%start_index(j,i), &
10877	surf_lsm_h%end_index(j,i)
10878	local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_out(m)
10879	ENDDO
10880	!
10881	!-- Urban-type surfaces
10882	DO m = surf_usm_h%start_index(j,i), &
10883	surf_usm_h%end_index(j,i)
10884	local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_out(m)
10885	ENDDO
10886	ENDDO
10887	ENDDO
10888	ELSE
10889	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
10890	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10891	rad_lw_out_xy_av = REAL( fill_value, KIND = wp )
10892	ENDIF
10893	DO i = nxl, nxr
10894	DO j = nys, nyn
10895	local_pf(i,j,nzb+1) = rad_lw_out_xy_av(j,i)
10896	ENDDO
10897	ENDDO
10898	ENDIF
10899	two_d = .TRUE.
10900	grid = 'zu1'
10901
10902	CASE ( 'rad_sw_in*_xy' ) ! 2d-array
10903	IF ( av == 0 ) THEN
10904	DO i = nxl, nxr
10905	DO j = nys, nyn
10906	!
10907	!-- Obtain rad_net from its respective surface type
10908	!-- Natural-type surfaces
10909	DO m = surf_lsm_h%start_index(j,i), &
10910	surf_lsm_h%end_index(j,i)
10911	local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_in(m)
10912	ENDDO
10913	!
10914	!-- Urban-type surfaces
10915	DO m = surf_usm_h%start_index(j,i), &
10916	surf_usm_h%end_index(j,i)
10917	local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_in(m)
10918	ENDDO
10919	ENDDO
10920	ENDDO
10921	ELSE
10922	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
10923	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10924	rad_sw_in_xy_av = REAL( fill_value, KIND = wp )
10925	ENDIF
10926	DO i = nxl, nxr
10927	DO j = nys, nyn
10928	local_pf(i,j,nzb+1) = rad_sw_in_xy_av(j,i)
10929	ENDDO
10930	ENDDO
10931	ENDIF
10932	two_d = .TRUE.
10933	grid = 'zu1'
10934
10935	CASE ( 'rad_sw_out*_xy' ) ! 2d-array
10936	IF ( av == 0 ) THEN
10937	DO i = nxl, nxr
10938	DO j = nys, nyn
10939	!
10940	!-- Obtain rad_net from its respective surface type
10941	!-- Natural-type surfaces
10942	DO m = surf_lsm_h%start_index(j,i), &
10943	surf_lsm_h%end_index(j,i)
10944	local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_out(m)
10945	ENDDO
10946	!
10947	!-- Urban-type surfaces
10948	DO m = surf_usm_h%start_index(j,i), &
10949	surf_usm_h%end_index(j,i)
10950	local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_out(m)
10951	ENDDO
10952	ENDDO
10953	ENDDO
10954	ELSE
10955	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
10956	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10957	rad_sw_out_xy_av = REAL( fill_value, KIND = wp )
10958	ENDIF
10959	DO i = nxl, nxr
10960	DO j = nys, nyn
10961	local_pf(i,j,nzb+1) = rad_sw_out_xy_av(j,i)
10962	ENDDO
10963	ENDDO
10964	ENDIF
10965	two_d = .TRUE.
10966	grid = 'zu1'
10967
10968	CASE ( 'rad_lw_in_xy', 'rad_lw_in_xz', 'rad_lw_in_yz' )
10969	IF ( av == 0 ) THEN
10970	DO i = nxl, nxr
10971	DO j = nys, nyn
10972	DO k = nzb_do, nzt_do
10973	local_pf(i,j,k) = rad_lw_in(k,j,i)
10974	ENDDO
10975	ENDDO
10976	ENDDO
10977	ELSE
10978	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
10979	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10980	rad_lw_in_av = REAL( fill_value, KIND = wp )
10981	ENDIF
10982	DO i = nxl, nxr
10983	DO j = nys, nyn
10984	DO k = nzb_do, nzt_do
10985	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
10986	ENDDO
10987	ENDDO
10988	ENDDO
10989	ENDIF
10990	IF ( mode == 'xy' ) grid = 'zu'
10991
10992	CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' )
10993	IF ( av == 0 ) THEN
10994	DO i = nxl, nxr
10995	DO j = nys, nyn
10996	DO k = nzb_do, nzt_do
10997	local_pf(i,j,k) = rad_lw_out(k,j,i)
10998	ENDDO
10999	ENDDO
11000	ENDDO
11001	ELSE
11002	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
11003	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11004	rad_lw_out_av = REAL( fill_value, KIND = wp )
11005	ENDIF
11006	DO i = nxl, nxr
11007	DO j = nys, nyn
11008	DO k = nzb_do, nzt_do
11009	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
11010	ENDDO
11011	ENDDO
11012	ENDDO
11013	ENDIF
11014	IF ( mode == 'xy' ) grid = 'zu'
11015
11016	CASE ( 'rad_lw_cs_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_cs_hr_yz' )
11017	IF ( av == 0 ) THEN
11018	DO i = nxl, nxr
11019	DO j = nys, nyn
11020	DO k = nzb_do, nzt_do
11021	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
11022	ENDDO
11023	ENDDO
11024	ENDDO
11025	ELSE
11026	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
11027	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11028	rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
11029	ENDIF
11030	DO i = nxl, nxr
11031	DO j = nys, nyn
11032	DO k = nzb_do, nzt_do
11033	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
11034	ENDDO
11035	ENDDO
11036	ENDDO
11037	ENDIF
11038	IF ( mode == 'xy' ) grid = 'zw'
11039
11040	CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' )
11041	IF ( av == 0 ) THEN
11042	DO i = nxl, nxr
11043	DO j = nys, nyn
11044	DO k = nzb_do, nzt_do
11045	local_pf(i,j,k) = rad_lw_hr(k,j,i)
11046	ENDDO
11047	ENDDO
11048	ENDDO
11049	ELSE
11050	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
11051	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11052	rad_lw_hr_av= REAL( fill_value, KIND = wp )
11053	ENDIF
11054	DO i = nxl, nxr
11055	DO j = nys, nyn
11056	DO k = nzb_do, nzt_do
11057	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
11058	ENDDO
11059	ENDDO
11060	ENDDO
11061	ENDIF
11062	IF ( mode == 'xy' ) grid = 'zw'
11063
11064	CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' )
11065	IF ( av == 0 ) THEN
11066	DO i = nxl, nxr
11067	DO j = nys, nyn
11068	DO k = nzb_do, nzt_do
11069	local_pf(i,j,k) = rad_sw_in(k,j,i)
11070	ENDDO
11071	ENDDO
11072	ENDDO
11073	ELSE
11074	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
11075	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11076	rad_sw_in_av = REAL( fill_value, KIND = wp )
11077	ENDIF
11078	DO i = nxl, nxr
11079	DO j = nys, nyn
11080	DO k = nzb_do, nzt_do
11081	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
11082	ENDDO
11083	ENDDO
11084	ENDDO
11085	ENDIF
11086	IF ( mode == 'xy' ) grid = 'zu'
11087
11088	CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' )
11089	IF ( av == 0 ) THEN
11090	DO i = nxl, nxr
11091	DO j = nys, nyn
11092	DO k = nzb_do, nzt_do
11093	local_pf(i,j,k) = rad_sw_out(k,j,i)
11094	ENDDO
11095	ENDDO
11096	ENDDO
11097	ELSE
11098	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
11099	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11100	rad_sw_out_av = REAL( fill_value, KIND = wp )
11101	ENDIF
11102	DO i = nxl, nxr
11103	DO j = nys, nyn
11104	DO k = nzb, nzt+1
11105	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
11106	ENDDO
11107	ENDDO
11108	ENDDO
11109	ENDIF
11110	IF ( mode == 'xy' ) grid = 'zu'
11111
11112	CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' )
11113	IF ( av == 0 ) THEN
11114	DO i = nxl, nxr
11115	DO j = nys, nyn
11116	DO k = nzb_do, nzt_do
11117	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
11118	ENDDO
11119	ENDDO
11120	ENDDO
11121	ELSE
11122	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
11123	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11124	rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
11125	ENDIF
11126	DO i = nxl, nxr
11127	DO j = nys, nyn
11128	DO k = nzb_do, nzt_do
11129	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
11130	ENDDO
11131	ENDDO
11132	ENDDO
11133	ENDIF
11134	IF ( mode == 'xy' ) grid = 'zw'
11135
11136	CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' )
11137	IF ( av == 0 ) THEN
11138	DO i = nxl, nxr
11139	DO j = nys, nyn
11140	DO k = nzb_do, nzt_do
11141	local_pf(i,j,k) = rad_sw_hr(k,j,i)
11142	ENDDO
11143	ENDDO
11144	ENDDO
11145	ELSE
11146	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
11147	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11148	rad_sw_hr_av = REAL( fill_value, KIND = wp )
11149	ENDIF
11150	DO i = nxl, nxr
11151	DO j = nys, nyn
11152	DO k = nzb_do, nzt_do
11153	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
11154	ENDDO
11155	ENDDO
11156	ENDDO
11157	ENDIF
11158	IF ( mode == 'xy' ) grid = 'zw'
11159
11160	CASE DEFAULT
11161	found = .FALSE.
11162	grid = 'none'
11163
11164	END SELECT
11165
11166	END SUBROUTINE radiation_data_output_2d
11167
11168
11169	!------------------------------------------------------------------------------!
11170	!
11171	! Description:
11172	! ------------
11173	!> Subroutine defining 3D output variables
11174	!------------------------------------------------------------------------------!
11175	SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do )
11176
11177
11178	USE indices
11179
11180	USE kinds
11181
11182
11183	IMPLICIT NONE
11184
11185	CHARACTER (LEN=*) :: variable !<
11186
11187	INTEGER(iwp) :: av !<
11188	INTEGER(iwp) :: i, j, k, l !<
11189	INTEGER(iwp) :: nzb_do !<
11190	INTEGER(iwp) :: nzt_do !<
11191
11192	LOGICAL :: found !<
11193
11194	REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute
11195
11196	REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !<
11197
11198	CHARACTER (len=varnamelength) :: var, surfid
11199	INTEGER(iwp) :: ids,idsint_u,idsint_l,isurf,isvf,isurfs,isurflt,ipcgb
11200	INTEGER(iwp) :: is, js, ks, istat
11201
11202	found = .TRUE.
11203	var = TRIM(variable)
11204
11205	!-- check if variable belongs to radiation related variables (starts with rad or rtm)
11206	IF ( len(var) < 3_iwp ) THEN
11207	found = .FALSE.
11208	RETURN
11209	ENDIF
11210
11211	IF ( var(1:3) /= 'rad' .AND. var(1:3) /= 'rtm' ) THEN
11212	found = .FALSE.
11213	RETURN
11214	ENDIF
11215
11216	ids = -1
11217	DO i = 0, nd-1
11218	k = len(TRIM(var))
11219	j = len(TRIM(dirname(i)))
11220	IF ( k-j+1 >= 1_iwp ) THEN
11221	IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN
11222	ids = i
11223	idsint_u = dirint_u(ids)
11224	idsint_l = dirint_l(ids)
11225	var = var(:k-j)
11226	EXIT
11227	ENDIF
11228	ENDIF
11229	ENDDO
11230	IF ( ids == -1 ) THEN
11231	var = TRIM(variable)
11232	ENDIF
11233
11234	IF ( (var(1:8) == 'rtm_svf_' .OR. var(1:8) == 'rtm_dif_') .AND. len(TRIM(var)) >= 13 ) THEN
11235	!-- svf values to particular surface
11236	surfid = var(9:)
11237	i = index(surfid,'_')
11238	j = index(surfid(i+1:),'_')
11239	READ(surfid(1:i-1),*, iostat=istat ) is
11240	IF ( istat == 0 ) THEN
11241	READ(surfid(i+1:i+j-1),*, iostat=istat ) js
11242	ENDIF
11243	IF ( istat == 0 ) THEN
11244	READ(surfid(i+j+1:),*, iostat=istat ) ks
11245	ENDIF
11246	IF ( istat == 0 ) THEN
11247	var = var(1:7)
11248	ENDIF
11249	ENDIF
11250
11251	local_pf = fill_value
11252
11253	SELECT CASE ( TRIM( var ) )
11254	!-- block of large scale radiation model (e.g. RRTMG) output variables
11255	CASE ( 'rad_sw_in' )
11256	IF ( av == 0 ) THEN
11257	DO i = nxl, nxr
11258	DO j = nys, nyn
11259	DO k = nzb_do, nzt_do
11260	local_pf(i,j,k) = rad_sw_in(k,j,i)
11261	ENDDO
11262	ENDDO
11263	ENDDO
11264	ELSE
11265	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
11266	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11267	rad_sw_in_av = REAL( fill_value, KIND = wp )
11268	ENDIF
11269	DO i = nxl, nxr
11270	DO j = nys, nyn
11271	DO k = nzb_do, nzt_do
11272	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
11273	ENDDO
11274	ENDDO
11275	ENDDO
11276	ENDIF
11277
11278	CASE ( 'rad_sw_out' )
11279	IF ( av == 0 ) THEN
11280	DO i = nxl, nxr
11281	DO j = nys, nyn
11282	DO k = nzb_do, nzt_do
11283	local_pf(i,j,k) = rad_sw_out(k,j,i)
11284	ENDDO
11285	ENDDO
11286	ENDDO
11287	ELSE
11288	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
11289	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11290	rad_sw_out_av = REAL( fill_value, KIND = wp )
11291	ENDIF
11292	DO i = nxl, nxr
11293	DO j = nys, nyn
11294	DO k = nzb_do, nzt_do
11295	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
11296	ENDDO
11297	ENDDO
11298	ENDDO
11299	ENDIF
11300
11301	CASE ( 'rad_sw_cs_hr' )
11302	IF ( av == 0 ) THEN
11303	DO i = nxl, nxr
11304	DO j = nys, nyn
11305	DO k = nzb_do, nzt_do
11306	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
11307	ENDDO
11308	ENDDO
11309	ENDDO
11310	ELSE
11311	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
11312	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11313	rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
11314	ENDIF
11315	DO i = nxl, nxr
11316	DO j = nys, nyn
11317	DO k = nzb_do, nzt_do
11318	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
11319	ENDDO
11320	ENDDO
11321	ENDDO
11322	ENDIF
11323
11324	CASE ( 'rad_sw_hr' )
11325	IF ( av == 0 ) THEN
11326	DO i = nxl, nxr
11327	DO j = nys, nyn
11328	DO k = nzb_do, nzt_do
11329	local_pf(i,j,k) = rad_sw_hr(k,j,i)
11330	ENDDO
11331	ENDDO
11332	ENDDO
11333	ELSE
11334	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
11335	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11336	rad_sw_hr_av = REAL( fill_value, KIND = wp )
11337	ENDIF
11338	DO i = nxl, nxr
11339	DO j = nys, nyn
11340	DO k = nzb_do, nzt_do
11341	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
11342	ENDDO
11343	ENDDO
11344	ENDDO
11345	ENDIF
11346
11347	CASE ( 'rad_lw_in' )
11348	IF ( av == 0 ) THEN
11349	DO i = nxl, nxr
11350	DO j = nys, nyn
11351	DO k = nzb_do, nzt_do
11352	local_pf(i,j,k) = rad_lw_in(k,j,i)
11353	ENDDO
11354	ENDDO
11355	ENDDO
11356	ELSE
11357	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
11358	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11359	rad_lw_in_av = REAL( fill_value, KIND = wp )
11360	ENDIF
11361	DO i = nxl, nxr
11362	DO j = nys, nyn
11363	DO k = nzb_do, nzt_do
11364	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
11365	ENDDO
11366	ENDDO
11367	ENDDO
11368	ENDIF
11369
11370	CASE ( 'rad_lw_out' )
11371	IF ( av == 0 ) THEN
11372	DO i = nxl, nxr
11373	DO j = nys, nyn
11374	DO k = nzb_do, nzt_do
11375	local_pf(i,j,k) = rad_lw_out(k,j,i)
11376	ENDDO
11377	ENDDO
11378	ENDDO
11379	ELSE
11380	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
11381	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11382	rad_lw_out_av = REAL( fill_value, KIND = wp )
11383	ENDIF
11384	DO i = nxl, nxr
11385	DO j = nys, nyn
11386	DO k = nzb_do, nzt_do
11387	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
11388	ENDDO
11389	ENDDO
11390	ENDDO
11391	ENDIF
11392
11393	CASE ( 'rad_lw_cs_hr' )
11394	IF ( av == 0 ) THEN
11395	DO i = nxl, nxr
11396	DO j = nys, nyn
11397	DO k = nzb_do, nzt_do
11398	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
11399	ENDDO
11400	ENDDO
11401	ENDDO
11402	ELSE
11403	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
11404	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11405	rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
11406	ENDIF
11407	DO i = nxl, nxr
11408	DO j = nys, nyn
11409	DO k = nzb_do, nzt_do
11410	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
11411	ENDDO
11412	ENDDO
11413	ENDDO
11414	ENDIF
11415
11416	CASE ( 'rad_lw_hr' )
11417	IF ( av == 0 ) THEN
11418	DO i = nxl, nxr
11419	DO j = nys, nyn
11420	DO k = nzb_do, nzt_do
11421	local_pf(i,j,k) = rad_lw_hr(k,j,i)
11422	ENDDO
11423	ENDDO
11424	ENDDO
11425	ELSE
11426	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
11427	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11428	rad_lw_hr_av = REAL( fill_value, KIND = wp )
11429	ENDIF
11430	DO i = nxl, nxr
11431	DO j = nys, nyn
11432	DO k = nzb_do, nzt_do
11433	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
11434	ENDDO
11435	ENDDO
11436	ENDDO
11437	ENDIF
11438
11439	CASE ( 'rtm_rad_net' )
11440	!-- array of complete radiation balance
11441	DO isurf = dirstart(ids), dirend(ids)
11442	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11443	IF ( av == 0 ) THEN
11444	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
11445	surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)
11446	ELSE
11447	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfradnet_av(isurf)
11448	ENDIF
11449	ENDIF
11450	ENDDO
11451
11452	CASE ( 'rtm_rad_insw' )
11453	!-- array of sw radiation falling to surface after i-th reflection
11454	DO isurf = dirstart(ids), dirend(ids)
11455	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11456	IF ( av == 0 ) THEN
11457	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw(isurf)
11458	ELSE
11459	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw_av(isurf)
11460	ENDIF
11461	ENDIF
11462	ENDDO
11463
11464	CASE ( 'rtm_rad_inlw' )
11465	!-- array of lw radiation falling to surface after i-th reflection
11466	DO isurf = dirstart(ids), dirend(ids)
11467	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11468	IF ( av == 0 ) THEN
11469	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf)
11470	ELSE
11471	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw_av(isurf)
11472	ENDIF
11473	ENDIF
11474	ENDDO
11475
11476	CASE ( 'rtm_rad_inswdir' )
11477	!-- array of direct sw radiation falling to surface from sun
11478	DO isurf = dirstart(ids), dirend(ids)
11479	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11480	IF ( av == 0 ) THEN
11481	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir(isurf)
11482	ELSE
11483	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir_av(isurf)
11484	ENDIF
11485	ENDIF
11486	ENDDO
11487
11488	CASE ( 'rtm_rad_inswdif' )
11489	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
11490	DO isurf = dirstart(ids), dirend(ids)
11491	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11492	IF ( av == 0 ) THEN
11493	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif(isurf)
11494	ELSE
11495	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif_av(isurf)
11496	ENDIF
11497	ENDIF
11498	ENDDO
11499
11500	CASE ( 'rtm_rad_inswref' )
11501	!-- array of sw radiation falling to surface from reflections
11502	DO isurf = dirstart(ids), dirend(ids)
11503	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11504	IF ( av == 0 ) THEN
11505	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
11506	surfinsw(isurf) - surfinswdir(isurf) - surfinswdif(isurf)
11507	ELSE
11508	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswref_av(isurf)
11509	ENDIF
11510	ENDIF
11511	ENDDO
11512
11513	CASE ( 'rtm_rad_inlwdif' )
11514	!-- array of difusion lw radiation falling to surface from sky and borders of the domain
11515	DO isurf = dirstart(ids), dirend(ids)
11516	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11517	IF ( av == 0 ) THEN
11518	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif(isurf)
11519	ELSE
11520	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif_av(isurf)
11521	ENDIF
11522	ENDIF
11523	ENDDO
11524
11525	CASE ( 'rtm_rad_inlwref' )
11526	!-- array of lw radiation falling to surface from reflections
11527	DO isurf = dirstart(ids), dirend(ids)
11528	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11529	IF ( av == 0 ) THEN
11530	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf) - surfinlwdif(isurf)
11531	ELSE
11532	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwref_av(isurf)
11533	ENDIF
11534	ENDIF
11535	ENDDO
11536
11537	CASE ( 'rtm_rad_outsw' )
11538	!-- array of sw radiation emitted from surface after i-th reflection
11539	DO isurf = dirstart(ids), dirend(ids)
11540	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11541	IF ( av == 0 ) THEN
11542	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw(isurf)
11543	ELSE
11544	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw_av(isurf)
11545	ENDIF
11546	ENDIF
11547	ENDDO
11548
11549	CASE ( 'rtm_rad_outlw' )
11550	!-- array of lw radiation emitted from surface after i-th reflection
11551	DO isurf = dirstart(ids), dirend(ids)
11552	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11553	IF ( av == 0 ) THEN
11554	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw(isurf)
11555	ELSE
11556	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw_av(isurf)
11557	ENDIF
11558	ENDIF
11559	ENDDO
11560
11561	CASE ( 'rtm_rad_ressw' )
11562	!-- average of array of residua of sw radiation absorbed in surface after last reflection
11563	DO isurf = dirstart(ids), dirend(ids)
11564	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11565	IF ( av == 0 ) THEN
11566	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins(isurf)
11567	ELSE
11568	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins_av(isurf)
11569	ENDIF
11570	ENDIF
11571	ENDDO
11572
11573	CASE ( 'rtm_rad_reslw' )
11574	!-- average of array of residua of lw radiation absorbed in surface after last reflection
11575	DO isurf = dirstart(ids), dirend(ids)
11576	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11577	IF ( av == 0 ) THEN
11578	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl(isurf)
11579	ELSE
11580	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl_av(isurf)
11581	ENDIF
11582	ENDIF
11583	ENDDO
11584
11585	CASE ( 'rtm_rad_pc_inlw' )
11586	!-- array of lw radiation absorbed by plant canopy
11587	DO ipcgb = 1, npcbl
11588	IF ( av == 0 ) THEN
11589	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw(ipcgb)
11590	ELSE
11591	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw_av(ipcgb)
11592	ENDIF
11593	ENDDO
11594
11595	CASE ( 'rtm_rad_pc_insw' )
11596	!-- array of sw radiation absorbed by plant canopy
11597	DO ipcgb = 1, npcbl
11598	IF ( av == 0 ) THEN
11599	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw(ipcgb)
11600	ELSE
11601	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw_av(ipcgb)
11602	ENDIF
11603	ENDDO
11604
11605	CASE ( 'rtm_rad_pc_inswdir' )
11606	!-- array of direct sw radiation absorbed by plant canopy
11607	DO ipcgb = 1, npcbl
11608	IF ( av == 0 ) THEN
11609	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir(ipcgb)
11610	ELSE
11611	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir_av(ipcgb)
11612	ENDIF
11613	ENDDO
11614
11615	CASE ( 'rtm_rad_pc_inswdif' )
11616	!-- array of diffuse sw radiation absorbed by plant canopy
11617	DO ipcgb = 1, npcbl
11618	IF ( av == 0 ) THEN
11619	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif(ipcgb)
11620	ELSE
11621	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif_av(ipcgb)
11622	ENDIF
11623	ENDDO
11624
11625	CASE ( 'rtm_rad_pc_inswref' )
11626	!-- array of reflected sw radiation absorbed by plant canopy
11627	DO ipcgb = 1, npcbl
11628	IF ( av == 0 ) THEN
11629	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = &
11630	pcbinsw(ipcgb) - pcbinswdir(ipcgb) - pcbinswdif(ipcgb)
11631	ELSE
11632	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswref_av(ipcgb)
11633	ENDIF
11634	ENDDO
11635
11636	CASE ( 'rtm_mrt_sw' )
11637	local_pf = REAL( fill_value, KIND = wp )
11638	IF ( av == 0 ) THEN
11639	DO l = 1, nmrtbl
11640	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw(l)
11641	ENDDO
11642	ELSE
11643	IF ( ALLOCATED( mrtinsw_av ) ) THEN
11644	DO l = 1, nmrtbl
11645	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw_av(l)
11646	ENDDO
11647	ENDIF
11648	ENDIF
11649
11650	CASE ( 'rtm_mrt_lw' )
11651	local_pf = REAL( fill_value, KIND = wp )
11652	IF ( av == 0 ) THEN
11653	DO l = 1, nmrtbl
11654	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw(l)
11655	ENDDO
11656	ELSE
11657	IF ( ALLOCATED( mrtinlw_av ) ) THEN
11658	DO l = 1, nmrtbl
11659	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw_av(l)
11660	ENDDO
11661	ENDIF
11662	ENDIF
11663
11664	CASE ( 'rtm_mrt' )
11665	local_pf = REAL( fill_value, KIND = wp )
11666	IF ( av == 0 ) THEN
11667	DO l = 1, nmrtbl
11668	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt(l)
11669	ENDDO
11670	ELSE
11671	IF ( ALLOCATED( mrt_av ) ) THEN
11672	DO l = 1, nmrtbl
11673	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt_av(l)
11674	ENDDO
11675	ENDIF
11676	ENDIF
11677	!
11678	!-- block of RTM output variables
11679	!-- variables are intended mainly for debugging and detailed analyse purposes
11680	CASE ( 'rtm_skyvf' )
11681	!
11682	!-- sky view factor
11683	DO isurf = dirstart(ids), dirend(ids)
11684	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11685	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvf(isurf)
11686	ENDIF
11687	ENDDO
11688
11689	CASE ( 'rtm_skyvft' )
11690	!
11691	!-- sky view factor
11692	DO isurf = dirstart(ids), dirend(ids)
11693	IF ( surfl(id,isurf) == ids ) THEN
11694	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvft(isurf)
11695	ENDIF
11696	ENDDO
11697
11698	CASE ( 'rtm_svf', 'rtm_dif' )
11699	!
11700	!-- shape view factors or iradiance factors to selected surface
11701	IF ( TRIM(var)=='rtm_svf' ) THEN
11702	k = 1
11703	ELSE
11704	k = 2
11705	ENDIF
11706	DO isvf = 1, nsvfl
11707	isurflt = svfsurf(1, isvf)
11708	isurfs = svfsurf(2, isvf)
11709
11710	IF ( surf(ix,isurfs) == is .AND. surf(iy,isurfs) == js .AND. surf(iz,isurfs) == ks .AND. &
11711	(surf(id,isurfs) == idsint_u .OR. surfl(id,isurfs) == idsint_l ) ) THEN
11712	!
11713	!-- correct source surface
11714	local_pf(surfl(ix,isurflt),surfl(iy,isurflt),surfl(iz,isurflt)) = svf(k,isvf)
11715	ENDIF
11716	ENDDO
11717
11718	CASE ( 'rtm_surfalb' )
11719	!
11720	!-- surface albedo
11721	DO isurf = dirstart(ids), dirend(ids)
11722	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11723	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = albedo_surf(isurf)
11724	ENDIF
11725	ENDDO
11726
11727	CASE ( 'rtm_surfemis' )
11728	!
11729	!-- surface emissivity, weighted average
11730	DO isurf = dirstart(ids), dirend(ids)
11731	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11732	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = emiss_surf(isurf)
11733	ENDIF
11734	ENDDO
11735
11736	CASE DEFAULT
11737	found = .FALSE.
11738
11739	END SELECT
11740
11741
11742	END SUBROUTINE radiation_data_output_3d
11743
11744	!------------------------------------------------------------------------------!
11745	!
11746	! Description:
11747	! ------------
11748	!> Subroutine defining masked data output
11749	!------------------------------------------------------------------------------!
11750	SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf, mid )
11751
11752	USE control_parameters
11753
11754	USE indices
11755
11756	USE kinds
11757
11758
11759	IMPLICIT NONE
11760
11761	CHARACTER (LEN=*) :: variable !<
11762
11763	CHARACTER(LEN=5) :: grid !< flag to distinquish between staggered grids
11764
11765	INTEGER(iwp) :: av !<
11766	INTEGER(iwp) :: i !<
11767	INTEGER(iwp) :: j !<
11768	INTEGER(iwp) :: k !<
11769	INTEGER(iwp) :: mid !< masked output running index
11770	INTEGER(iwp) :: topo_top_index !< k index of highest horizontal surface
11771
11772	LOGICAL :: found !< true if output array was found
11773	LOGICAL :: resorted !< true if array is resorted
11774
11775
11776	REAL(wp), &
11777	DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: &
11778	local_pf !<
11779
11780	REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to array which needs to be resorted for output
11781
11782
11783	found = .TRUE.
11784	grid = 's'
11785	resorted = .FALSE.
11786
11787	SELECT CASE ( TRIM( variable ) )
11788
11789
11790	CASE ( 'rad_lw_in' )
11791	IF ( av == 0 ) THEN
11792	to_be_resorted => rad_lw_in
11793	ELSE
11794	to_be_resorted => rad_lw_in_av
11795	ENDIF
11796
11797	CASE ( 'rad_lw_out' )
11798	IF ( av == 0 ) THEN
11799	to_be_resorted => rad_lw_out
11800	ELSE
11801	to_be_resorted => rad_lw_out_av
11802	ENDIF
11803
11804	CASE ( 'rad_lw_cs_hr' )
11805	IF ( av == 0 ) THEN
11806	to_be_resorted => rad_lw_cs_hr
11807	ELSE
11808	to_be_resorted => rad_lw_cs_hr_av
11809	ENDIF
11810
11811	CASE ( 'rad_lw_hr' )
11812	IF ( av == 0 ) THEN
11813	to_be_resorted => rad_lw_hr
11814	ELSE
11815	to_be_resorted => rad_lw_hr_av
11816	ENDIF
11817
11818	CASE ( 'rad_sw_in' )
11819	IF ( av == 0 ) THEN
11820	to_be_resorted => rad_sw_in
11821	ELSE
11822	to_be_resorted => rad_sw_in_av
11823	ENDIF
11824
11825	CASE ( 'rad_sw_out' )
11826	IF ( av == 0 ) THEN
11827	to_be_resorted => rad_sw_out
11828	ELSE
11829	to_be_resorted => rad_sw_out_av
11830	ENDIF
11831
11832	CASE ( 'rad_sw_cs_hr' )
11833	IF ( av == 0 ) THEN
11834	to_be_resorted => rad_sw_cs_hr
11835	ELSE
11836	to_be_resorted => rad_sw_cs_hr_av
11837	ENDIF
11838
11839	CASE ( 'rad_sw_hr' )
11840	IF ( av == 0 ) THEN
11841	to_be_resorted => rad_sw_hr
11842	ELSE
11843	to_be_resorted => rad_sw_hr_av
11844	ENDIF
11845
11846	CASE DEFAULT
11847	found = .FALSE.
11848
11849	END SELECT
11850
11851	!
11852	!-- Resort the array to be output, if not done above
11853	IF ( found .AND. .NOT. resorted ) THEN
11854	IF ( .NOT. mask_surface(mid) ) THEN
11855	!
11856	!-- Default masked output
11857	DO i = 1, mask_size_l(mid,1)
11858	DO j = 1, mask_size_l(mid,2)
11859	DO k = 1, mask_size_l(mid,3)
11860	local_pf(i,j,k) = to_be_resorted(mask_k(mid,k), &
11861	mask_j(mid,j),mask_i(mid,i))
11862	ENDDO
11863	ENDDO
11864	ENDDO
11865
11866	ELSE
11867	!
11868	!-- Terrain-following masked output
11869	DO i = 1, mask_size_l(mid,1)
11870	DO j = 1, mask_size_l(mid,2)
11871	!
11872	!-- Get k index of highest horizontal surface
11873	topo_top_index = topo_top_ind(mask_j(mid,j), &
11874	mask_i(mid,i), &
11875	0 )
11876	!
11877	!-- Save output array
11878	DO k = 1, mask_size_l(mid,3)
11879	local_pf(i,j,k) = to_be_resorted( &
11880	MIN( topo_top_index+mask_k(mid,k), &
11881	nzt+1 ), &
11882	mask_j(mid,j), &
11883	mask_i(mid,i) )
11884	ENDDO
11885	ENDDO
11886	ENDDO
11887
11888	ENDIF
11889	ENDIF
11890
11891
11892
11893	END SUBROUTINE radiation_data_output_mask
11894
11895
11896	!------------------------------------------------------------------------------!
11897	! Description:
11898	! ------------
11899	!> Subroutine writes local (subdomain) restart data
11900	!------------------------------------------------------------------------------!
11901	SUBROUTINE radiation_wrd_local
11902
11903
11904	IMPLICIT NONE
11905
11906
11907	IF ( ALLOCATED( rad_net_av ) ) THEN
11908	CALL wrd_write_string( 'rad_net_av' )
11909	WRITE ( 14 ) rad_net_av
11910	ENDIF
11911
11912	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
11913	CALL wrd_write_string( 'rad_lw_in_xy_av' )
11914	WRITE ( 14 ) rad_lw_in_xy_av
11915	ENDIF
11916
11917	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
11918	CALL wrd_write_string( 'rad_lw_out_xy_av' )
11919	WRITE ( 14 ) rad_lw_out_xy_av
11920	ENDIF
11921
11922	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
11923	CALL wrd_write_string( 'rad_sw_in_xy_av' )
11924	WRITE ( 14 ) rad_sw_in_xy_av
11925	ENDIF
11926
11927	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
11928	CALL wrd_write_string( 'rad_sw_out_xy_av' )
11929	WRITE ( 14 ) rad_sw_out_xy_av
11930	ENDIF
11931
11932	IF ( ALLOCATED( rad_lw_in ) ) THEN
11933	CALL wrd_write_string( 'rad_lw_in' )
11934	WRITE ( 14 ) rad_lw_in
11935	ENDIF
11936
11937	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
11938	CALL wrd_write_string( 'rad_lw_in_av' )
11939	WRITE ( 14 ) rad_lw_in_av
11940	ENDIF
11941
11942	IF ( ALLOCATED( rad_lw_out ) ) THEN
11943	CALL wrd_write_string( 'rad_lw_out' )
11944	WRITE ( 14 ) rad_lw_out
11945	ENDIF
11946
11947	IF ( ALLOCATED( rad_lw_out_av) ) THEN
11948	CALL wrd_write_string( 'rad_lw_out_av' )
11949	WRITE ( 14 ) rad_lw_out_av
11950	ENDIF
11951
11952	IF ( ALLOCATED( rad_lw_cs_hr) ) THEN
11953	CALL wrd_write_string( 'rad_lw_cs_hr' )
11954	WRITE ( 14 ) rad_lw_cs_hr
11955	ENDIF
11956
11957	IF ( ALLOCATED( rad_lw_cs_hr_av) ) THEN
11958	CALL wrd_write_string( 'rad_lw_cs_hr_av' )
11959	WRITE ( 14 ) rad_lw_cs_hr_av
11960	ENDIF
11961
11962	IF ( ALLOCATED( rad_lw_hr) ) THEN
11963	CALL wrd_write_string( 'rad_lw_hr' )
11964	WRITE ( 14 ) rad_lw_hr
11965	ENDIF
11966
11967	IF ( ALLOCATED( rad_lw_hr_av) ) THEN
11968	CALL wrd_write_string( 'rad_lw_hr_av' )
11969	WRITE ( 14 ) rad_lw_hr_av
11970	ENDIF
11971
11972	IF ( ALLOCATED( rad_sw_in) ) THEN
11973	CALL wrd_write_string( 'rad_sw_in' )
11974	WRITE ( 14 ) rad_sw_in
11975	ENDIF
11976
11977	IF ( ALLOCATED( rad_sw_in_av) ) THEN
11978	CALL wrd_write_string( 'rad_sw_in_av' )
11979	WRITE ( 14 ) rad_sw_in_av
11980	ENDIF
11981
11982	IF ( ALLOCATED( rad_sw_out) ) THEN
11983	CALL wrd_write_string( 'rad_sw_out' )
11984	WRITE ( 14 ) rad_sw_out
11985	ENDIF
11986
11987	IF ( ALLOCATED( rad_sw_out_av) ) THEN
11988	CALL wrd_write_string( 'rad_sw_out_av' )
11989	WRITE ( 14 ) rad_sw_out_av
11990	ENDIF
11991
11992	IF ( ALLOCATED( rad_sw_cs_hr) ) THEN
11993	CALL wrd_write_string( 'rad_sw_cs_hr' )
11994	WRITE ( 14 ) rad_sw_cs_hr
11995	ENDIF
11996
11997	IF ( ALLOCATED( rad_sw_cs_hr_av) ) THEN
11998	CALL wrd_write_string( 'rad_sw_cs_hr_av' )
11999	WRITE ( 14 ) rad_sw_cs_hr_av
12000	ENDIF
12001
12002	IF ( ALLOCATED( rad_sw_hr) ) THEN
12003	CALL wrd_write_string( 'rad_sw_hr' )
12004	WRITE ( 14 ) rad_sw_hr
12005	ENDIF
12006
12007	IF ( ALLOCATED( rad_sw_hr_av) ) THEN
12008	CALL wrd_write_string( 'rad_sw_hr_av' )
12009	WRITE ( 14 ) rad_sw_hr_av
12010	ENDIF
12011
12012
12013	END SUBROUTINE radiation_wrd_local
12014
12015	!------------------------------------------------------------------------------!
12016	! Description:
12017	! ------------
12018	!> Subroutine reads local (subdomain) restart data
12019	!------------------------------------------------------------------------------!
12020	SUBROUTINE radiation_rrd_local( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, &
12021	nxr_on_file, nynf, nync, nyn_on_file, nysf, &
12022	nysc, nys_on_file, tmp_2d, tmp_3d, found )
12023
12024
12025	USE control_parameters
12026
12027	USE indices
12028
12029	USE kinds
12030
12031	USE pegrid
12032
12033
12034	IMPLICIT NONE
12035
12036	INTEGER(iwp) :: k !<
12037	INTEGER(iwp) :: nxlc !<
12038	INTEGER(iwp) :: nxlf !<
12039	INTEGER(iwp) :: nxl_on_file !<
12040	INTEGER(iwp) :: nxrc !<
12041	INTEGER(iwp) :: nxrf !<
12042	INTEGER(iwp) :: nxr_on_file !<
12043	INTEGER(iwp) :: nync !<
12044	INTEGER(iwp) :: nynf !<
12045	INTEGER(iwp) :: nyn_on_file !<
12046	INTEGER(iwp) :: nysc !<
12047	INTEGER(iwp) :: nysf !<
12048	INTEGER(iwp) :: nys_on_file !<
12049
12050	LOGICAL, INTENT(OUT) :: found
12051
12052	REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d !<
12053
12054	REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !<
12055
12056	REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2 !<
12057
12058
12059	found = .TRUE.
12060
12061
12062	SELECT CASE ( restart_string(1:length) )
12063
12064	CASE ( 'rad_net_av' )
12065	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
12066	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
12067	ENDIF
12068	IF ( k == 1 ) READ ( 13 ) tmp_2d
12069	rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12070	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12071
12072	CASE ( 'rad_lw_in_xy_av' )
12073	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
12074	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
12075	ENDIF
12076	IF ( k == 1 ) READ ( 13 ) tmp_2d
12077	rad_lw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12078	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12079
12080	CASE ( 'rad_lw_out_xy_av' )
12081	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
12082	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
12083	ENDIF
12084	IF ( k == 1 ) READ ( 13 ) tmp_2d
12085	rad_lw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12086	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12087
12088	CASE ( 'rad_sw_in_xy_av' )
12089	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
12090	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
12091	ENDIF
12092	IF ( k == 1 ) READ ( 13 ) tmp_2d
12093	rad_sw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12094	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12095
12096	CASE ( 'rad_sw_out_xy_av' )
12097	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
12098	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
12099	ENDIF
12100	IF ( k == 1 ) READ ( 13 ) tmp_2d
12101	rad_sw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12102	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12103
12104	CASE ( 'rad_lw_in' )
12105	IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN
12106	IF ( radiation_scheme == 'clear-sky' .OR. &
12107	radiation_scheme == 'constant' .OR. &
12108	radiation_scheme == 'external' ) THEN
12109	ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
12110	ELSE
12111	ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12112	ENDIF
12113	ENDIF
12114	IF ( k == 1 ) THEN
12115	IF ( radiation_scheme == 'clear-sky' .OR. &
12116	radiation_scheme == 'constant' .OR. &
12117	radiation_scheme == 'external' ) THEN
12118	READ ( 13 ) tmp_3d2
12119	rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12120	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12121	ELSE
12122	READ ( 13 ) tmp_3d
12123	rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12124	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12125	ENDIF
12126	ENDIF
12127
12128	CASE ( 'rad_lw_in_av' )
12129	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
12130	IF ( radiation_scheme == 'clear-sky' .OR. &
12131	radiation_scheme == 'constant' .OR. &
12132	radiation_scheme == 'external' ) THEN
12133	ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
12134	ELSE
12135	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12136	ENDIF
12137	ENDIF
12138	IF ( k == 1 ) THEN
12139	IF ( radiation_scheme == 'clear-sky' .OR. &
12140	radiation_scheme == 'constant' .OR. &
12141	radiation_scheme == 'external' ) THEN
12142	READ ( 13 ) tmp_3d2
12143	rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
12144	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12145	ELSE
12146	READ ( 13 ) tmp_3d
12147	rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12148	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12149	ENDIF
12150	ENDIF
12151
12152	CASE ( 'rad_lw_out' )
12153	IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN
12154	IF ( radiation_scheme == 'clear-sky' .OR. &
12155	radiation_scheme == 'constant' .OR. &
12156	radiation_scheme == 'external' ) THEN
12157	ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
12158	ELSE
12159	ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12160	ENDIF
12161	ENDIF
12162	IF ( k == 1 ) THEN
12163	IF ( radiation_scheme == 'clear-sky' .OR. &
12164	radiation_scheme == 'constant' .OR. &
12165	radiation_scheme == 'external' ) THEN
12166	READ ( 13 ) tmp_3d2
12167	rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12168	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12169	ELSE
12170	READ ( 13 ) tmp_3d
12171	rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12172	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12173	ENDIF
12174	ENDIF
12175
12176	CASE ( 'rad_lw_out_av' )
12177	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
12178	IF ( radiation_scheme == 'clear-sky' .OR. &
12179	radiation_scheme == 'constant' .OR. &
12180	radiation_scheme == 'external' ) THEN
12181	ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
12182	ELSE
12183	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12184	ENDIF
12185	ENDIF
12186	IF ( k == 1 ) THEN
12187	IF ( radiation_scheme == 'clear-sky' .OR. &
12188	radiation_scheme == 'constant' .OR. &
12189	radiation_scheme == 'external' ) THEN
12190	READ ( 13 ) tmp_3d2
12191	rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
12192	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12193	ELSE
12194	READ ( 13 ) tmp_3d
12195	rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12196	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12197	ENDIF
12198	ENDIF
12199
12200	CASE ( 'rad_lw_cs_hr' )
12201	IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN
12202	ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12203	ENDIF
12204	IF ( k == 1 ) READ ( 13 ) tmp_3d
12205	rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12206	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12207
12208	CASE ( 'rad_lw_cs_hr_av' )
12209	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
12210	ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12211	ENDIF
12212	IF ( k == 1 ) READ ( 13 ) tmp_3d
12213	rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12214	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12215
12216	CASE ( 'rad_lw_hr' )
12217	IF ( .NOT. ALLOCATED( rad_lw_hr ) ) THEN
12218	ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12219	ENDIF
12220	IF ( k == 1 ) READ ( 13 ) tmp_3d
12221	rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12222	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12223
12224	CASE ( 'rad_lw_hr_av' )
12225	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
12226	ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12227	ENDIF
12228	IF ( k == 1 ) READ ( 13 ) tmp_3d
12229	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12230	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12231
12232	CASE ( 'rad_sw_in' )
12233	IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN
12234	IF ( radiation_scheme == 'clear-sky' .OR. &
12235	radiation_scheme == 'constant' .OR. &
12236	radiation_scheme == 'external' ) THEN
12237	ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
12238	ELSE
12239	ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12240	ENDIF
12241	ENDIF
12242	IF ( k == 1 ) THEN
12243	IF ( radiation_scheme == 'clear-sky' .OR. &
12244	radiation_scheme == 'constant' .OR. &
12245	radiation_scheme == 'external' ) THEN
12246	READ ( 13 ) tmp_3d2
12247	rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12248	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12249	ELSE
12250	READ ( 13 ) tmp_3d
12251	rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12252	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12253	ENDIF
12254	ENDIF
12255
12256	CASE ( 'rad_sw_in_av' )
12257	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
12258	IF ( radiation_scheme == 'clear-sky' .OR. &
12259	radiation_scheme == 'constant' .OR. &
12260	radiation_scheme == 'external' ) THEN
12261	ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
12262	ELSE
12263	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12264	ENDIF
12265	ENDIF
12266	IF ( k == 1 ) THEN
12267	IF ( radiation_scheme == 'clear-sky' .OR. &
12268	radiation_scheme == 'constant' .OR. &
12269	radiation_scheme == 'external' ) THEN
12270	READ ( 13 ) tmp_3d2
12271	rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
12272	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12273	ELSE
12274	READ ( 13 ) tmp_3d
12275	rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12276	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12277	ENDIF
12278	ENDIF
12279
12280	CASE ( 'rad_sw_out' )
12281	IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN
12282	IF ( radiation_scheme == 'clear-sky' .OR. &
12283	radiation_scheme == 'constant' .OR. &
12284	radiation_scheme == 'external' ) THEN
12285	ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
12286	ELSE
12287	ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12288	ENDIF
12289	ENDIF
12290	IF ( k == 1 ) THEN
12291	IF ( radiation_scheme == 'clear-sky' .OR. &
12292	radiation_scheme == 'constant' .OR. &
12293	radiation_scheme == 'external' ) THEN
12294	READ ( 13 ) tmp_3d2
12295	rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12296	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12297	ELSE
12298	READ ( 13 ) tmp_3d
12299	rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12300	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12301	ENDIF
12302	ENDIF
12303
12304	CASE ( 'rad_sw_out_av' )
12305	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
12306	IF ( radiation_scheme == 'clear-sky' .OR. &
12307	radiation_scheme == 'constant' .OR. &
12308	radiation_scheme == 'external' ) THEN
12309	ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
12310	ELSE
12311	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12312	ENDIF
12313	ENDIF
12314	IF ( k == 1 ) THEN
12315	IF ( radiation_scheme == 'clear-sky' .OR. &
12316	radiation_scheme == 'constant' .OR. &
12317	radiation_scheme == 'external' ) THEN
12318	READ ( 13 ) tmp_3d2
12319	rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
12320	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12321	ELSE
12322	READ ( 13 ) tmp_3d
12323	rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12324	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12325	ENDIF
12326	ENDIF
12327
12328	CASE ( 'rad_sw_cs_hr' )
12329	IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) THEN
12330	ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12331	ENDIF
12332	IF ( k == 1 ) READ ( 13 ) tmp_3d
12333	rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12334	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12335
12336	CASE ( 'rad_sw_cs_hr_av' )
12337	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
12338	ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12339	ENDIF
12340	IF ( k == 1 ) READ ( 13 ) tmp_3d
12341	rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12342	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12343
12344	CASE ( 'rad_sw_hr' )
12345	IF ( .NOT. ALLOCATED( rad_sw_hr ) ) THEN
12346	ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12347	ENDIF
12348	IF ( k == 1 ) READ ( 13 ) tmp_3d
12349	rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12350	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12351
12352	CASE ( 'rad_sw_hr_av' )
12353	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
12354	ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12355	ENDIF
12356	IF ( k == 1 ) READ ( 13 ) tmp_3d
12357	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12358	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12359
12360	CASE DEFAULT
12361
12362	found = .FALSE.
12363
12364	END SELECT
12365
12366	END SUBROUTINE radiation_rrd_local
12367
12368
12369	END MODULE radiation_model_mod

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

Context Navigation

source: palm/trunk/SOURCE/radiation_model_mod.f90 @ 4429

Download in other formats: